+2018-05-31 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Find_Primitive_Eq): New subprogram.
+ * exp_ch4.adb (Expand_Composite_Equality): Use the new subprogram
+ Find_Primitive_Eq to search for the primitive of types whose underlying
+ type is a tagged type.
+
2018-05-31 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Analyze_Pragma.Check_Loop_Pragma_Placement): Inverse
is
Loc : constant Source_Ptr := Sloc (Nod);
Full_Type : Entity_Id;
- Prim : Elmt_Id;
Eq_Op : Entity_Id;
function Find_Primitive_Eq return Node_Id;
-- Case of tagged record types
elsif Is_Tagged_Type (Full_Type) then
-
- -- Call the primitive operation "=" of this type
-
- if Is_Class_Wide_Type (Full_Type) then
- Full_Type := Root_Type (Full_Type);
- end if;
-
- -- If this is an untagged private type completed with a derivation of
- -- an untagged private type whose full view is a tagged type, we use
- -- the primitive operations of the private parent type (since it does
- -- not have a full view, and also because its equality primitive may
- -- have been overridden in its untagged full view).
-
- if Inherits_From_Tagged_Full_View (Typ) then
- Prim := First_Elmt (Collect_Primitive_Operations (Typ));
- else
- Prim := First_Elmt (Primitive_Operations (Full_Type));
- end if;
-
- loop
- Eq_Op := Node (Prim);
- exit when Chars (Eq_Op) = Name_Op_Eq
- and then Etype (First_Formal (Eq_Op)) =
- Etype (Next_Formal (First_Formal (Eq_Op)))
- and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
- Next_Elmt (Prim);
- pragma Assert (Present (Prim));
- end loop;
-
- Eq_Op := Node (Prim);
+ Eq_Op := Find_Primitive_Eq (Typ);
+ pragma Assert (Present (Eq_Op));
return
Make_Function_Call (Loc,
end loop;
end Find_Placement_In_State_Space;
+ -----------------------
+ -- Find_Primitive_Eq --
+ -----------------------
+
+ function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is
+ function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id;
+ -- Search for the equality primitive; return Empty if the primitive is
+ -- not found.
+
+ function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is
+ Prim_E : Elmt_Id := First_Elmt (Prims_List);
+ Prim : Entity_Id;
+
+ begin
+ while Present (Prim_E) loop
+ Prim := Node (Prim_E);
+
+ -- Locate primitive equality with the right signature
+
+ if Chars (Prim) = Name_Op_Eq
+ and then Etype (First_Formal (Prim)) =
+ Etype (Next_Formal (First_Formal (Prim)))
+ and then Base_Type (Etype (Prim)) = Standard_Boolean
+ then
+ return Prim;
+ end if;
+
+ Next_Elmt (Prim_E);
+ end loop;
+
+ return Empty;
+ end Find_Eq_Prim;
+
+ -- Local Variables
+
+ Full_Type : Entity_Id;
+ Eq_Prim : Entity_Id;
+
+ -- Start of processing for Find_Primitive_Eq
+
+ begin
+ if Is_Private_Type (Typ) then
+ Full_Type := Underlying_Type (Typ);
+ else
+ Full_Type := Typ;
+ end if;
+
+ if No (Full_Type) then
+ return Empty;
+ end if;
+
+ Full_Type := Base_Type (Full_Type);
+
+ -- When the base type itself is private, use the full view
+
+ if Is_Private_Type (Full_Type) then
+ Full_Type := Underlying_Type (Full_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Full_Type) then
+ Full_Type := Root_Type (Full_Type);
+ end if;
+
+ if not Is_Tagged_Type (Full_Type) then
+ Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
+
+ -- If this is an untagged private type completed with a derivation of
+ -- an untagged private type whose full view is a tagged type, we use
+ -- the primitive operations of the private parent type (since it does
+ -- not have a full view, and also because its equality primitive may
+ -- have been overridden in its untagged full view). If no equality was
+ -- defined for it then take its dispatching equality primitive.
+
+ elsif Inherits_From_Tagged_Full_View (Typ) then
+ Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
+
+ if No (Eq_Prim) then
+ Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
+ end if;
+
+ else
+ Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
+ end if;
+
+ return Eq_Prim;
+ end Find_Primitive_Eq;
+
------------------------
-- Find_Specific_Type --
------------------------
-- If the state space is that of a package, Pack_Id denotes its entity,
-- otherwise Pack_Id is Empty.
+ function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id;
+ -- Locate primitive equality for type if it exists. Return Empty if it is
+ -- not available.
+
function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
-- Find specific type of a class-wide type, and handle the case of an
-- incomplete type coming either from a limited_with clause or from an
+2018-05-31 Javier Miranda <miranda@adacore.com>
+
+ * gnat.dg/tagged1.adb, gnat.dg/tagged1.ads: New testcase.
+
2018-05-31 Sameera Deshpande <sameera.deshpande@linaro.org>
* gcc.target/aarch64/advsimd-intrinsics/vld1x3.c: New test for
--- /dev/null
+-- { dg-do compile }
+
+package body Tagged1 is
+ procedure Dummy is null;
+end Tagged1;
--- /dev/null
+with Ada.Containers.Vectors;
+with Ada.Containers;
+with Ada.Finalization;
+
+package Tagged1 is
+
+ generic
+ type Target_Type (<>) is limited private;
+ package A is
+ type Smart_Pointer_Type is private;
+ private
+ type Smart_Pointer_Type
+ is new Ada.Finalization.Controlled with null record;
+ end;
+
+ generic
+ type Target_Type (<>) is limited private;
+ package SP is
+ type Smart_Pointer_Type is private;
+ private
+ package S is new A (Integer);
+ type Smart_Pointer_Type is new S.Smart_Pointer_Type;
+ end;
+
+ type Root_Type is tagged record
+ Orders : Integer;
+ end record;
+ package Smarts is new SP
+ (Target_Type => Root_Type'Class);
+
+ type Fat_Reference_Type is new Smarts.Smart_Pointer_Type;
+ type EST is record
+ Orders : Fat_Reference_Type;
+ end record;
+
+ package V is new Ada.Containers.Vectors (Positive, EST);
+
+ procedure Dummy;
+end;
projects / gcc.git / commitdiff