+2019-12-13 Steve Baird <baird@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function
+ from within Expand_N_Op_Eq.Find_Equality out to immediately
+ within Expand_N_Op_Eq in order to give it greater visibility.
+ Add a new Typ parameter (defaulted to Empty) which, if
+ non-empty, means the function will return False in the case of
+ an equality op for some other type.
+ * (Expand_N_Op_Eq.User_Defined_Primitive_Equality_Op): A new
+ function. Given an untagged record type, finds the corresponding
+ user-defined primitive equality op (if any). May return Empty.
+ Ignores visibility.
+ * (Expand_N_Op): For Ada2012 or later, check for presence of a
+ user-defined primitive equality op before falling back on the
+ usual predefined component-by-component comparison. If found,
+ then call the user-defined op instead.
+
2019-12-13 Justin Squirek <squirek@adacore.com>
* sem_ch6.adb (Check_Overriding_Indicator): Modify condition to
-- build and analyze call, adding conversions if the operation is
-- inherited.
+ function Is_Equality (Subp : Entity_Id;
+ Typ : Entity_Id := Empty) return Boolean;
+ -- Determine whether arbitrary Entity_Id denotes a function with the
+ -- right name and profile for an equality op, specifically for the
+ -- base type Typ if Typ is nonempty.
+
function Find_Equality (Prims : Elist_Id) return Entity_Id;
-- Find a primitive equality function within primitive operation list
-- Prims.
+ function User_Defined_Primitive_Equality_Op
+ (Typ : Entity_Id) return Entity_Id;
+ -- Find a user-defined primitive equality function for a given untagged
+ -- record type, ignoring visibility. Return Empty if no such op found.
+
function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
-- Determines whether a type has a subcomponent of an unconstrained
-- Unchecked_Union subtype. Typ is a record type.
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Build_Equality_Call;
+ -----------------
+ -- Is_Equality --
+ -----------------
+
+ function Is_Equality (Subp : Entity_Id;
+ Typ : Entity_Id := Empty) return Boolean is
+ Formal_1 : Entity_Id;
+ Formal_2 : Entity_Id;
+ begin
+ -- The equality function carries name "=", returns Boolean, and has
+ -- exactly two formal parameters of an identical type.
+
+ if Ekind (Subp) = E_Function
+ and then Chars (Subp) = Name_Op_Eq
+ and then Base_Type (Etype (Subp)) = Standard_Boolean
+ then
+ Formal_1 := First_Formal (Subp);
+ Formal_2 := Empty;
+
+ if Present (Formal_1) then
+ Formal_2 := Next_Formal (Formal_1);
+ end if;
+
+ return
+ Present (Formal_1)
+ and then Present (Formal_2)
+ and then No (Next_Formal (Formal_2))
+ and then Base_Type (Etype (Formal_1)) =
+ Base_Type (Etype (Formal_2))
+ and then
+ (not Present (Typ)
+ or else Implementation_Base_Type (Etype (Formal_1)) = Typ);
+ end if;
+
+ return False;
+ end Is_Equality;
+
-------------------
-- Find_Equality --
-------------------
-- Find an equality in a possible alias chain starting from primitive
-- operation Prim.
- function Is_Equality (Id : Entity_Id) return Boolean;
- -- Determine whether arbitrary entity Id denotes an equality
-
---------------------------
-- Find_Aliased_Equality --
---------------------------
return Empty;
end Find_Aliased_Equality;
- -----------------
- -- Is_Equality --
- -----------------
-
- function Is_Equality (Id : Entity_Id) return Boolean is
- Formal_1 : Entity_Id;
- Formal_2 : Entity_Id;
-
- begin
- -- The equality function carries name "=", returns Boolean, and
- -- has exactly two formal parameters of an identical type.
-
- if Ekind (Id) = E_Function
- and then Chars (Id) = Name_Op_Eq
- and then Base_Type (Etype (Id)) = Standard_Boolean
- then
- Formal_1 := First_Formal (Id);
- Formal_2 := Empty;
-
- if Present (Formal_1) then
- Formal_2 := Next_Formal (Formal_1);
- end if;
-
- return
- Present (Formal_1)
- and then Present (Formal_2)
- and then Etype (Formal_1) = Etype (Formal_2)
- and then No (Next_Formal (Formal_2));
- end if;
-
- return False;
- end Is_Equality;
-
-- Local variables
Eq_Prim : Entity_Id;
return Eq_Prim;
end Find_Equality;
+ ----------------------------------------
+ -- User_Defined_Primitive_Equality_Op --
+ ----------------------------------------
+
+ function User_Defined_Primitive_Equality_Op
+ (Typ : Entity_Id) return Entity_Id
+ is
+ Enclosing_Scope : constant Node_Id := Scope (Typ);
+ E : Entity_Id;
+ begin
+ -- Prune this search by somehow not looking at decls that precede
+ -- the declaration of the first view of Typ (which might be a partial
+ -- view)???
+
+ for Private_Entities in Boolean loop
+ if Private_Entities then
+ if Ekind (Enclosing_Scope) /= E_Package then
+ exit;
+ end if;
+ E := First_Private_Entity (Enclosing_Scope);
+
+ else
+ E := First_Entity (Enclosing_Scope);
+ end if;
+
+ while Present (E) loop
+ if Is_Equality (E, Typ) then
+ return E;
+ end if;
+ E := Next_Entity (E);
+ end loop;
+ end loop;
+
+ if Is_Derived_Type (Typ) then
+ return User_Defined_Primitive_Equality_Op
+ (Implementation_Base_Type (Etype (Typ)));
+ end if;
+
+ return Empty;
+ end User_Defined_Primitive_Equality_Op;
+
------------------------------------
-- Has_Unconstrained_UU_Component --
------------------------------------
(Find_Equality (Primitive_Operations (Typl)));
end if;
+ -- See AI12-0101 (which only removes a legality rule) and then
+ -- AI05-0123 (which then applies in the previously illegal case).
+ -- AI12-0101 is a binding interpretation.
+
+ elsif Ada_Version >= Ada_2012
+ and then Present (User_Defined_Primitive_Equality_Op (Typl))
+ then
+ Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl));
+
-- Ada 2005 (AI-216): Program_Error is raised when evaluating the
-- predefined equality operator for a type which has a subcomponent
-- of an Unchecked_Union type whose nominal subtype is unconstrained.
projects / gcc.git / commitdiff