[Ada] Fix implementation issues with equality for untagged record types

This moves the implementation of AI12-0101 + AI05-0123 from the expander
to the semantic analyzer and completes the implementation of AI12-0413,
which are both binding interpretations in Ada 2012, fixing a few bugs in
the process and removing a fair amount of duplicated code throughout.

gcc/ada/

	* einfo-utils.adb (Remove_Entity): Fix couple of oversights.
	* exp_ch3.adb (Is_User_Defined_Equality): Delete.
	(User_Defined_Eq): Call Get_User_Defined_Equality.
	(Make_Eq_Body): Likewise.
	(Predefined_Primitive_Eq_Body): Call Is_User_Defined_Equality.
	* exp_ch4.adb (Build_Eq_Call): Call Get_User_Defined_Equality.
	(Is_Equality): Delete.
	(User_Defined_Primitive_Equality_Op): Likewise.
	(Find_Aliased_Equality): Call Is_User_Defined_Equality.
	(Expand_N_Op_Eq): Call Underlying_Type unconditionally.
	Do not implement AI12-0101 + AI05-0123 here.
	(Expand_Set_Membership): Call Resolve_Membership_Equality.
	* exp_ch6.adb (Expand_Call_Helper): Remove obsolete code.
	* sem_aux.ads (Is_Record_Or_Limited_Type): Delete.
	* sem_aux.adb (Is_Record_Or_Limited_Type): Likewise.
	* sem_ch4.ads (Nondispatching_Call_To_Abstract_Operation): Declare.
	* sem_ch4.adb (Analyze_Call): Call Call_Abstract_Operation.
	(Analyze_Membership_Op): Call Resolve_Membership_Equality.
	(Nondispatching_Call_To_Abstract_Operation): New procedure.
	(Remove_Abstract_Operations): Call it.
	* sem_ch6.adb (Check_Untagged_Equality): Remove obsolete error and
	call Is_User_Defined_Equality.
	* sem_ch7.adb (Inspect_Untagged_Record_Completion): New procedure
	implementing AI12-0101 + AI05-0123.
	(Analyze_Package_Specification): Call it.
	(Declare_Inherited_Private_Subprograms): Minor tweak.
	(Uninstall_Declarations): Likewise.
	* sem_disp.adb (Check_Direct_Call): Adjust to new implementation
	of Is_User_Defined_Equality.
	* sem_res.ads (Resolve_Membership_Equality): Declare.
	* sem_res.adb (Resolve): Replace direct error handling with call to
	Nondispatching_Call_To_Abstract_Operation
	(Resolve_Call): Likewise.
	(Resolve_Equality_Op): Likewise.  mplement AI12-0413.
	(Resolve_Membership_Equality): New procedure.
	(Resolve_Membership_Op): Call Get_User_Defined_Equality.
	* sem_util.ads (Get_User_Defined_Eq): Rename into...
	(Get_User_Defined_Equality): ...this.
	* sem_util.adb (Get_User_Defined_Eq): Rename into...
	(Get_User_Defined_Equality): ...this. Call Is_User_Defined_Equality.
	(Is_User_Defined_Equality): Also check the profile but remove tests
	on Comes_From_Source and Parent.
	* sinfo.ads (Generic_Parent_Type): Adjust field description.
	* uintp.ads (Ubool): Invoke user-defined equality in predicate.

1 files changed, 81 insertions, 19 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 4306e49..12735da 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3215,11 +3215,11 @@ package body Sem_Res is
          then
             Get_First_Interp (N, I, It);
             while Present (It.Typ) loop
-               if Present (It.Abstract_Op) and then
-                 Etype (It.Abstract_Op) = Typ
+               if Present (It.Abstract_Op)
+                 and then Etype (It.Abstract_Op) = Typ
                then
-                  Error_Msg_NE
-                    ("cannot call abstract subprogram &!", N, It.Abstract_Op);
+                  Nondispatching_Call_To_Abstract_Operation
+                    (N, It.Abstract_Op);
                   return;
                end if;
 
@@ -7063,24 +7063,19 @@ package body Sem_Res is
       --  If the subprogram is a primitive operation, check whether or not
       --  it is a correct dispatching call.
 
-      if Is_Overloadable (Nam)
-        and then Is_Dispatching_Operation (Nam)
-      then
+      if Is_Overloadable (Nam) and then Is_Dispatching_Operation (Nam) then
          Check_Dispatching_Call (N);
 
-      elsif Ekind (Nam) /= E_Subprogram_Type
-        and then Is_Abstract_Subprogram (Nam)
-        and then not In_Instance
-      then
-         Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
+      --  If the subprogram is an abstract operation, then flag an error
+
+      elsif Is_Overloadable (Nam) and then Is_Abstract_Subprogram (Nam) then
+         Nondispatching_Call_To_Abstract_Operation (N, Nam);
       end if;
 
       --  If this is a dispatching call, generate the appropriate reference,
       --  for better source navigation in GNAT Studio.
 
-      if Is_Overloadable (Nam)
-        and then Present (Controlling_Argument (N))
-      then
+      if Is_Overloadable (Nam) and then Present (Controlling_Argument (N)) then
          Generate_Reference (Nam, Subp, 'R');
 
       --  Normal case, not a dispatching call: generate a call reference
@@ -8918,6 +8913,41 @@ package body Sem_Res is
          Resolve (L, T);
          Resolve (R, T);
 
+         --  AI12-0413: user-defined primitive equality of an untagged record
+         --  type hides the predefined equality operator, including within a
+         --  generic, and if it is declared abstract, results in an illegal
+         --  instance if the operator is used in the spec, or in the raising
+         --  of Program_Error if used in the body of an instance.
+
+         if Nkind (N) = N_Op_Eq
+           and then In_Instance
+           and then Ada_Version >= Ada_2012
+         then
+            declare
+               U : constant Entity_Id := Underlying_Type (T);
+
+               Eq : Entity_Id;
+
+            begin
+               if Present (U)
+                 and then Is_Record_Type (U)
+                 and then not Is_Tagged_Type (U)
+               then
+                  Eq := Get_User_Defined_Equality (T);
+
+                  if Present (Eq) then
+                     if Is_Abstract_Subprogram (Eq) then
+                        Nondispatching_Call_To_Abstract_Operation (N, Eq);
+                     else
+                        Rewrite_Operator_As_Call (N, Eq);
+                     end if;
+
+                     return;
+                  end if;
+               end if;
+            end;
+         end if;
+
          --  If the unique type is a class-wide type then it will be expanded
          --  into a dispatching call to the predefined primitive. Therefore we
          --  check here for potential violation of such restriction.
@@ -8977,8 +9007,8 @@ package body Sem_Res is
          if Nkind (N) = N_Op_Eq
            or else Comes_From_Source (Entity (N))
            or else Ekind (Entity (N)) = E_Operator
-           or else Is_Intrinsic_Subprogram
-                     (Corresponding_Equality (Entity (N)))
+           or else
+             Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N)))
          then
             Analyze_Dimension (N);
             Eval_Relational_Op (N);
@@ -8986,7 +9016,7 @@ package body Sem_Res is
          elsif Nkind (N) = N_Op_Ne
            and then Is_Abstract_Subprogram (Entity (N))
          then
-            Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
+            Nondispatching_Call_To_Abstract_Operation (N, Entity (N));
          end if;
       end if;
    end Resolve_Equality_Op;
@@ -9837,6 +9867,38 @@ package body Sem_Res is
       Eval_Logical_Op (N);
    end Resolve_Logical_Op;
 
+   ---------------------------------
+   -- Resolve_Membership_Equality --
+   ---------------------------------
+
+   procedure Resolve_Membership_Equality (N : Node_Id; Typ : Entity_Id) is
+      Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+   begin
+      --  RM 4.5.2(4.1/3): if the type is limited, then it shall have a visible
+      --  primitive equality operator. This means that we can use the regular
+      --  visibility-based resolution and reset Entity in order to trigger it.
+
+      if Is_Limited_Type (Typ) then
+         Set_Entity (N, Empty);
+
+      --  RM 4.5.2(28.1/3): if the type is a record, then the membership test
+      --  uses the primitive equality for the type [even if it is not visible].
+      --  We only deal with the untagged case here, because the tagged case is
+      --  handled uniformly in the expander.
+
+      elsif Is_Record_Type (Utyp) and then not Is_Tagged_Type (Utyp) then
+         declare
+            Eq_Id : constant Entity_Id := Get_User_Defined_Equality (Typ);
+
+         begin
+            if Present (Eq_Id) then
+               Rewrite_Operator_As_Call (N, Eq_Id);
+            end if;
+         end;
+      end if;
+   end Resolve_Membership_Equality;
+
    ---------------------------
    -- Resolve_Membership_Op --
    ---------------------------
@@ -9953,7 +10015,7 @@ package body Sem_Res is
          --  following warning appears useful for the most common case.
 
          if Is_Scalar_Type (Etype (L))
-           and then Present (Get_User_Defined_Eq (Etype (L)))
+           and then Present (Get_User_Defined_Equality (Etype (L)))
          then
             Error_Msg_NE
               ("membership test on& uses predefined equality?", N, Etype (L));