+2018-05-29 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new
+ subprogram Inherits_From_Tagged_Full_View to identify more reliably
+ untagged private types completed with a derivation of an untagged
+ private whose full view is a tagged type.
+ * sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New
+ subprogram.
+ (Collect_Primitive_Operations): Handle untagged private types completed
+ with a derivation of an untagged private type whose full view is a
+ tagged type. In such case, collecting the list of primitives we may
+ find two equality primitives: one associated with the untagged private
+ and another associated with the ultimate tagged type (and we must
+ remove from the returned list this latter one).
+
2018-05-29 Ed Schonberg <schonberg@adacore.com>
* exp_unst.adb (Visit_Node): Handle statement sequences that include an
Full_Type := Root_Type (Full_Type);
end if;
- -- If this is derived from an untagged private type completed with a
- -- tagged type, it does not have a full view, so we use the primitive
- -- operations of the private type. This check should no longer be
- -- necessary when these types receive their full views ???
-
- if Is_Private_Type (Typ)
- and then not Is_Tagged_Type (Typ)
- and then not Is_Controlled (Typ)
- and then Is_Derived_Type (Typ)
- and then No (Full_View (Typ))
- then
+ -- 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));
return;
end if;
- -- If this is derived from an untagged private type completed with
- -- a tagged type, it does not have a full view, so we use the
- -- primitive operations of the private type. This check should no
- -- longer be necessary when these types get their full views???
+ -- 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 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 (A_Typ) then
- if Is_Private_Type (A_Typ)
- and then not Is_Tagged_Type (A_Typ)
- and then Is_Derived_Type (A_Typ)
- and then No (Full_View (A_Typ))
- then
-- Search for equality operation, checking that the operands
-- have the same type. Note that we must find a matching entry,
-- or something is very wrong.
----------------------------------
function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
- B_Type : constant Entity_Id := Base_Type (T);
- B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
- B_Scope : Entity_Id := Scope (B_Type);
- Op_List : Elist_Id;
- Formal : Entity_Id;
- Is_Prim : Boolean;
- Is_Type_In_Pkg : Boolean;
- Formal_Derived : Boolean := False;
- Id : Entity_Id;
+ B_Type : constant Entity_Id := Base_Type (T);
function Match (E : Entity_Id) return Boolean;
-- True if E's base type is B_Type, or E is of an anonymous access type
and then Full_View (Etyp) = B_Type);
end Match;
+ -- Local variables
+
+ B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
+ B_Scope : Entity_Id := Scope (B_Type);
+ Op_List : Elist_Id;
+ Eq_Prims_List : Elist_Id := No_Elist;
+ Formal : Entity_Id;
+ Is_Prim : Boolean;
+ Is_Type_In_Pkg : Boolean;
+ Formal_Derived : Boolean := False;
+ Id : Entity_Id;
+
-- Start of processing for Collect_Primitive_Operations
begin
else
Append_Elmt (Id, Op_List);
+
+ -- Save collected equality primitives for later filtering
+ -- (if we are processing a private type for which we can
+ -- collect several candidates).
+
+ if Inherits_From_Tagged_Full_View (T)
+ and then Chars (Id) = Name_Op_Eq
+ and then Etype (First_Formal (Id)) =
+ Etype (Next_Formal (First_Formal (Id)))
+ then
+ if No (Eq_Prims_List) then
+ Eq_Prims_List := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Id, Eq_Prims_List);
+ end if;
end if;
end if;
end if;
Id := First_Entity (System_Aux_Id);
end if;
end loop;
+
+ -- Filter collected equality primitives
+
+ if Inherits_From_Tagged_Full_View (T)
+ and then Present (Eq_Prims_List)
+ then
+ declare
+ First : constant Elmt_Id := First_Elmt (Eq_Prims_List);
+ Second : Elmt_Id;
+
+ begin
+ pragma Assert (No (Next_Elmt (First))
+ or else No (Next_Elmt (Next_Elmt (First))));
+
+ -- No action needed if we have collected a single equality
+ -- primitive
+
+ if Present (Next_Elmt (First)) then
+ Second := Next_Elmt (First);
+
+ if Is_Dispatching_Operation
+ (Ultimate_Alias (Node (First)))
+ then
+ Remove (Op_List, Node (First));
+
+ elsif Is_Dispatching_Operation
+ (Ultimate_Alias (Node (Second)))
+ then
+ Remove (Op_List, Node (Second));
+
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+ end if;
+ end;
+ end if;
end if;
return Op_List;
end if;
end Inherit_Rep_Item_Chain;
+ ------------------------------------
+ -- Inherits_From_Tagged_Full_View --
+ ------------------------------------
+
+ function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is
+ begin
+ return Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ and then Is_Private_Type (Full_View (Typ))
+ and then not Is_Tagged_Type (Full_View (Typ))
+ and then Present (Underlying_Type (Full_View (Typ)))
+ and then Is_Tagged_Type (Underlying_Type (Full_View (Typ)));
+ end Inherits_From_Tagged_Full_View;
+
---------------------------------
-- Insert_Explicit_Dereference --
---------------------------------
-- Inherit the rep item chain of type From_Typ without clobbering any
-- existing rep items on Typ's chain. Typ is the destination type.
+ function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean;
+ pragma Inline (Inherits_From_Tagged_Full_View);
+ -- Return True if Typ is an untagged private type completed with a
+ -- derivation of an untagged private type declaration whose full view
+ -- is a tagged type.
+
procedure Insert_Explicit_Dereference (N : Node_Id);
-- In a context that requires a composite or subprogram type and where a
-- prefix is an access type, rewrite the access type node N (which is the
+2018-05-29 Javier Miranda <miranda@adacore.com>
+
+ * gnat.dg/equal2.adb: New testcase.
+
2018-05-29 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/float_attributes_overflows.adb: New testcase.
--- /dev/null
+-- { dg-do run }
+
+procedure Equal2 is
+
+ package L1 is
+ type T is private;
+ overriding function "=" (Left, Right : T) return Boolean;
+ private
+ type T is tagged record
+ I : Integer := 0;
+ end record;
+ end L1;
+
+ package L2 is
+ type T is private;
+ private
+ type T is new L1.T;
+ overriding function "=" (Left, Right : T) return Boolean;
+ end L2;
+
+ package body L1 is
+ overriding function "=" (Left, Right : T) return Boolean is
+ begin
+ return False;
+ end "=";
+ end L1;
+
+ package body L2 is
+ overriding function "=" (Left, Right : T) return Boolean is
+ begin
+ return True;
+ end "=";
+ end L2;
+
+ use type L2.T;
+ Left, Right : L2.T;
+begin
+ if Left /= Right then
+ raise Program_Error;
+ end if;
+end;
projects / gcc.git / commitdiff