[multiple changes]

2010-09-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb: Improve error message on untagged equality.
	* sem.adb (Semantics): Include subprogram bodies that act as spec.

2010-09-09  Javier Miranda  <miranda@adacore.com>

	* sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded.

From-SVN: r164062

gcc/ada/ChangeLog

+2010-09-09  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb: Improve error message on untagged equality.
+	* sem.adb (Semantics): Include subprogram bodies that act as spec.
+
+2010-09-09  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded.
+
 2010-09-09  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.

gcc/ada/exp_ch3.adb

@@ -312,6 +312,12 @@ package body Exp_Ch3 is
    --  invoking the inherited subprogram's parent subprogram and extended
    --  with a null association list.
 
+   function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
+   --  Ada 2005 (AI-251): Makes specs for null procedures associated with any
+   --  null procedures inherited from an interface type that have not been
+   --  overridden. Only one null procedure will be created for a given set of
+   --  inherited null procedures with homographic profiles.
+
    function Predef_Spec_Or_Body
      (Loc      : Source_Ptr;
       Tag_Typ  : Entity_Id;
@@ -5882,8 +5888,8 @@ package body Exp_Ch3 is
       --  user-defined equality function). Used to pass this entity from
       --  Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
 
-      Wrapper_Decl_List   : List_Id := No_List;
-      Wrapper_Body_List   : List_Id := No_List;
+      Wrapper_Decl_List : List_Id := No_List;
+      Wrapper_Body_List : List_Id := No_List;
 
    --  Start of processing for Expand_Freeze_Record_Type
 
@@ -6086,6 +6092,20 @@ package body Exp_Ch3 is
                Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
             end if;
 
+            --  Ada 2005 (AI-251): For a nonabstract type extension, build
+            --  null procedure declarations for each set of homographic null
+            --  procedures that are inherited from interface types but not
+            --  overridden. This is done to ensure that the dispatch table
+            --  entry associated with such null primitives are properly filled.
+
+            if Ada_Version >= Ada_05
+              and then Etype (Def_Id) /= Def_Id
+              and then not Is_Abstract_Type (Def_Id)
+              and then Has_Interfaces (Def_Id)
+            then
+               Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id));
+            end if;
+
             Set_Is_Frozen (Def_Id);
             Set_All_DT_Position (Def_Id);
 
@@ -8004,6 +8024,95 @@ package body Exp_Ch3 is
       end if;
    end Make_Eq_If;
 
+   -------------------------------
+   -- Make_Null_Procedure_Specs --
+   -------------------------------
+
+   function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is
+      Decl_List      : constant List_Id    := New_List;
+      Loc            : constant Source_Ptr := Sloc (Tag_Typ);
+      Formal         : Entity_Id;
+      Formal_List    : List_Id;
+      New_Param_Spec : Node_Id;
+      Parent_Subp    : Entity_Id;
+      Prim_Elmt      : Elmt_Id;
+      Subp           : Entity_Id;
+
+   begin
+      Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+      while Present (Prim_Elmt) loop
+         Subp := Node (Prim_Elmt);
+
+         --  If a null procedure inherited from an interface has not been
+         --  overridden, then we build a null procedure declaration to
+         --  override the inherited procedure.
+
+         Parent_Subp := Alias (Subp);
+
+         if Present (Parent_Subp)
+           and then Is_Null_Interface_Primitive (Parent_Subp)
+         then
+            Formal_List := No_List;
+            Formal := First_Formal (Subp);
+
+            if Present (Formal) then
+               Formal_List := New_List;
+
+               while Present (Formal) loop
+
+                  --  Copy the parameter spec including default expressions
+
+                  New_Param_Spec :=
+                    New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+
+                  --  Generate a new defining identifier for the new formal.
+                  --  required because New_Copy_Tree does not duplicate
+                  --  semantic fields (except itypes).
+
+                  Set_Defining_Identifier (New_Param_Spec,
+                    Make_Defining_Identifier (Sloc (Formal),
+                      Chars => Chars (Formal)));
+
+                  --  For controlling arguments we must change their
+                  --  parameter type to reference the tagged type (instead
+                  --  of the interface type)
+
+                  if Is_Controlling_Formal (Formal) then
+                     if Nkind (Parameter_Type (Parent (Formal)))
+                       = N_Identifier
+                     then
+                        Set_Parameter_Type (New_Param_Spec,
+                          New_Occurrence_Of (Tag_Typ, Loc));
+
+                     else pragma Assert
+                            (Nkind (Parameter_Type (Parent (Formal)))
+                               = N_Access_Definition);
+                        Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+                          New_Occurrence_Of (Tag_Typ, Loc));
+                     end if;
+                  end if;
+
+                  Append (New_Param_Spec, Formal_List);
+
+                  Next_Formal (Formal);
+               end loop;
+            end if;
+
+            Append_To (Decl_List,
+              Make_Subprogram_Declaration (Loc,
+                Make_Procedure_Specification (Loc,
+                  Defining_Unit_Name =>
+                    Make_Defining_Identifier (Loc, Chars (Subp)),
+                  Parameter_Specifications => Formal_List,
+                  Null_Present => True)));
+         end if;
+
+         Next_Elmt (Prim_Elmt);
+      end loop;
+
+      return Decl_List;
+   end Make_Null_Procedure_Specs;
+
    -------------------------------------
    -- Make_Predefined_Primitive_Specs --
    -------------------------------------

gcc/ada/sem.adb

@@ -1454,14 +1454,16 @@ package body Sem is
          --  Do analysis, and then append the compilation unit onto the
          --  Comp_Unit_List, if appropriate. This is done after analysis, so
          --  if this unit depends on some others, they have already been
-         --  appended. We ignore bodies, except for the main unit itself. We
-         --  have also to guard against ill-formed subunits that have an
-         --  improper context.
+         --  appended. We ignore bodies, except for the main unit itself, and
+         --   for subprogram bodies that act as specs. We have also to guard
+         --   against ill-formed subunits that have an improper context.
 
          Do_Analyze;
 
          if Present (Comp_Unit)
            and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
+           and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
+             or else not Acts_As_Spec (Comp_Unit))
            and then not In_Extended_Main_Source_Unit (Comp_Unit)
          then
             null;

gcc/ada/sem_ch13.adb

@@ -44,7 +44,6 @@ with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
-with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
@@ -2357,106 +2356,6 @@ package body Sem_Ch13 is
    procedure Analyze_Freeze_Entity (N : Node_Id) is
       E : constant Entity_Id := Entity (N);
 
-      function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
-      --  Ada 2005 (AI-251): Makes specs for null procedures associated with
-      --  null procedures inherited from interface types that have not been
-      --  overridden. Only one null procedure will be created for a given set
-      --  of inherited null procedures with homographic profiles.
-
-      -------------------------------
-      -- Make_Null_Procedure_Specs --
-      -------------------------------
-
-      function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id
-      is
-         Decl_List      : constant List_Id    := New_List;
-         Loc            : constant Source_Ptr := Sloc (Tag_Typ);
-         Formal         : Entity_Id;
-         Formal_List    : List_Id;
-         New_Param_Spec : Node_Id;
-         Parent_Subp    : Entity_Id;
-         Prim_Elmt      : Elmt_Id;
-         Proc_Decl      : Node_Id;
-         Subp           : Entity_Id;
-
-      begin
-         Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
-         while Present (Prim_Elmt) loop
-            Subp := Node (Prim_Elmt);
-
-            --  If a null procedure inherited from an interface has not been
-            --  overridden, then we build a null procedure declaration to
-            --  override the inherited procedure.
-
-            Parent_Subp := Alias (Subp);
-
-            if Present (Parent_Subp)
-              and then Is_Null_Interface_Primitive (Parent_Subp)
-            then
-               Formal_List := No_List;
-               Formal := First_Formal (Subp);
-
-               if Present (Formal) then
-                  Formal_List := New_List;
-
-                  while Present (Formal) loop
-
-                     --  Copy the parameter spec including default expressions
-
-                     New_Param_Spec :=
-                       New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
-
-                     --  Generate a new defining identifier for the new formal.
-                     --  required because New_Copy_Tree does not duplicate
-                     --  semantic fields (except itypes).
-
-                     Set_Defining_Identifier (New_Param_Spec,
-                       Make_Defining_Identifier (Sloc (Formal),
-                         Chars => Chars (Formal)));
-
-                     --  For controlling arguments we must change their
-                     --  parameter type to reference the tagged type (instead
-                     --  of the interface type)
-
-                     if Is_Controlling_Formal (Formal) then
-                        if Nkind (Parameter_Type (Parent (Formal))) =
-                                                              N_Identifier
-                        then
-                           Set_Parameter_Type (New_Param_Spec,
-                             New_Occurrence_Of (Tag_Typ, Loc));
-
-                        else pragma Assert
-                               (Nkind (Parameter_Type (Parent (Formal)))
-                                  = N_Access_Definition);
-                           Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
-                             New_Occurrence_Of (Tag_Typ, Loc));
-                        end if;
-                     end if;
-
-                     Append (New_Param_Spec, Formal_List);
-
-                     Next_Formal (Formal);
-                  end loop;
-               end if;
-
-               Proc_Decl :=
-                 Make_Subprogram_Declaration (Loc,
-                   Make_Procedure_Specification (Loc,
-                     Defining_Unit_Name =>
-                       Make_Defining_Identifier (Loc, Chars (Subp)),
-                     Parameter_Specifications => Formal_List,
-                     Null_Present => True));
-               Append_To (Decl_List, Proc_Decl);
-            end if;
-
-            Next_Elmt (Prim_Elmt);
-         end loop;
-
-         return Decl_List;
-      end Make_Null_Procedure_Specs;
-
-   --  Start of processing for Analyze_Freeze_Entity
-
    begin
       --  For tagged types covering interfaces add internal entities that link
       --  the primitives of the interfaces with the primitives that cover them.
@@ -2475,21 +2374,6 @@ package body Sem_Ch13 is
         and then not Is_Interface (E)
         and then Has_Interfaces (E)
       then
-         --  Add specs of non-overridden null interface primitives. During
-         --  semantic analysis this is required to ensure consistency of the
-         --  contents of the list of primitives of the tagged type. Routine
-         --  Add_Internal_Interface_Entities will take care of adding to such
-         --  list the internal entities that link each interface primitive with
-         --  the primitive of Tagged_Type that covers it; hence these specs
-         --  must be added before invoking Add_Internal_Interface_Entities.
-         --  In the expansion this consistency is required to ensure that the
-         --  dispatch table slots associated with non-overridden null interface
-         --  primitives are properly filled.
-
-         if not Is_Abstract_Type (E) then
-            Insert_Actions (N, Make_Null_Procedure_Specs (E));
-         end if;
-
          --  This would be a good common place to call the routine that checks
          --  overriding of interface primitives (and thus factorize calls to
          --  Check_Abstract_Overriding located at different contexts in the

gcc/ada/sem_ch6.adb

@@ -166,6 +166,13 @@ package body Sem_Ch6 is
    --  True otherwise. Proc is the entity for the procedure case and is used
    --  in posting the warning message.
 
+   procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
+   --  In Ada 2012, a primitive equality operator on an untagged record type
+   --  must appear before the type is frozen, and have the same visibility as
+   --  that of the type. This procedure checks that this rule is met, and
+   --  otherwise emits an error on the subprogram declaration and a warning
+   --  on the earlier freeze point if it is easy to locate.
+
    procedure Enter_Overloaded_Entity (S : Entity_Id);
    --  This procedure makes S, a new overloaded entity, into the first visible
    --  entity with that name.
@@ -5790,6 +5797,51 @@ package body Sem_Ch6 is
    end Enter_Overloaded_Entity;
 
    -----------------------------
+   -- Check_Untagged_Equality --
+   -----------------------------
+
+   procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
+      Typ      : constant Entity_Id := Etype (First_Formal (Eq_Op));
+      Decl     : constant Node_Id   := Unit_Declaration_Node (Eq_Op);
+      Obj_Decl : Node_Id;
+
+   begin
+      if Nkind (Decl) = N_Subprogram_Declaration
+        and then Is_Record_Type (Typ)
+        and then not Is_Tagged_Type (Typ)
+      then
+         if Is_Frozen (Typ) then
+            Error_Msg_NE
+              ("equality operator must be declared "
+                & "before type& is frozen", Eq_Op, Typ);
+
+            Obj_Decl := Next (Parent (Typ));
+            while Present (Obj_Decl)
+              and then Obj_Decl /= Decl
+            loop
+               if Nkind (Obj_Decl) = N_Object_Declaration
+                 and then Etype (Defining_Identifier (Obj_Decl)) = Typ
+               then
+                  Error_Msg_NE ("type& is frozen by declaration?",
+                     Obj_Decl, Typ);
+                  Error_Msg_N
+                    ("\an equality operator cannot be declared after this "
+                      & "point ('R'M 4.5.2 (9.8)) (Ada2012))?", Obj_Decl);
+                  exit;
+               end if;
+
+               Next (Obj_Decl);
+            end loop;
+
+         elsif not In_Same_List (Parent (Typ), Decl)
+           and then not Is_Limited_Type (Typ)
+         then
+            Error_Msg_N ("equality operator appears too late", Eq_Op);
+         end if;
+      end if;
+   end Check_Untagged_Equality;
+
+   -----------------------------
    -- Find_Corresponding_Spec --
    -----------------------------
 
@@ -7975,32 +8027,9 @@ package body Sem_Ch6 is
          then
             Make_Inequality_Operator (S);
 
-            --  In Ada 2012, a primitive equality operator on a record type
-            --  must appear before the type is frozen, and have the same
-            --  visibility as the type.
-
-            declare
-               Typ  : constant Entity_Id := Etype (First_Formal (S));
-               Decl : constant Node_Id   := Unit_Declaration_Node (S);
-
-            begin
-               if Ada_Version >= Ada_12
-                 and then Nkind (Decl) = N_Subprogram_Declaration
-                 and then Is_Record_Type (Typ)
-               then
-                  if Is_Frozen (Typ) then
-                     Error_Msg_NE
-                       ("equality operator must be declared "
-                         & "before type& is frozen", S, Typ);
-
-                  elsif not In_Same_List (Parent (Typ), Decl)
-                    and then not Is_Limited_Type (Typ)
-                  then
-                     Error_Msg_N
-                       ("equality operator appears too late", S);
-                  end if;
-               end if;
-            end;
+            if Ada_Version >= Ada_12 then
+               Check_Untagged_Equality (S);
+            end if;
          end if;
    end New_Overloaded_Entity;