sem_ch7.ads, [...] (Inspect_Deferred_Constant_Completion): Move out of Analyze_Package_Declaration...

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* sem_ch7.ads, sem_ch7.adb (Inspect_Deferred_Constant_Completion): Move
	out of Analyze_Package_Declaration, because processing must be applied
	to package bodies as well, for deferred constants completed by pragmas.
	(Analyze_Package_Declaration): When the package declaration being
	analyzed does not require an explicit body, call Check_Completion.
	(May_Need_Implicit_Body): An implicit body is required when a package
	spec contains the declaration of a remote access-to-classwide type.
	(Analyze_Package_Body): If the package contains RACWs, append the
	pending subprogram bodies generated by exp_dist at the end of the body.
	(New_Private_Type,Unit_Requires_Body): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type.
	(Preserve_Full_Attributes): The full entity list is not an attribute
	that must be preserved from full to partial view.

        * sem_dist.adb (Add_RAS_Dereference_TSS):
        Change primitive name to _Call so it cannot clash with any legal
        identifier, and be special-cased in Check_Completion.
        Mark the full view of the designated type for the RACW associated with
        a RAS as Comes_From_Source to get proper view switching when installing
        private declarations.
        Provite a placeholder nested package body along with the nested spec
        to have a place for Append_RACW_Bodies to generate the calling stubs
        and stream attributes.

From-SVN: r123596

3 files changed, 202 insertions, 117 deletions

diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 2e03e1f..9d62cbe 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -35,6 +35,7 @@ with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Disp; use Exp_Disp;
+with Exp_Dist; use Exp_Dist;
 with Exp_Dbug; use Exp_Dbug;
 with Lib;      use Lib;
 with Lib.Xref; use Lib.Xref;
@@ -89,19 +90,25 @@ package body Sem_Ch7 is
 
    procedure Check_Anonymous_Access_Types
      (Spec_Id : Entity_Id;
-      P_Body  :  Node_Id);
+      P_Body  : Node_Id);
    --  If the spec of a package has a limited_with_clause, it may declare
-   --  anonymous access types whose designated type is a limited view, such
-   --  an anonymous access return type for a function. This access type
-   --  cannot be elaborated in the spec itself, but it may need an itype
-   --  reference if it is used within a nested scope. In that case the itype
-   --  reference is created at the beginning of the corresponding package body
-   --  and inserted before other body declarations.
+   --  anonymous access types whose designated type is a limited view, such an
+   --  anonymous access return type for a function. This access type cannot be
+   --  elaborated in the spec itself, but it may need an itype reference if it
+   --  is used within a nested scope. In that case the itype reference is
+   --  created at the beginning of the corresponding package body and inserted
+   --  before other body declarations.
+
+   procedure Inspect_Deferred_Constant_Completion (Decls : List_Id);
+   --  Examines the deferred constants in the private part of the package
+   --  specification, or in a package body. Emits the error message
+   --  "constant declaration requires initialization expression" if not
+   --  completed by an Import pragma.
 
    procedure Install_Package_Entity (Id : Entity_Id);
-   --  Basic procedure for the previous two. Places one entity on its
-   --  visibility chain, and recurses on the visible part if the entity
-   --  is an inner package.
+   --  Supporting procedure for Install_{Visible,Private}_Declarations.
+   --  Places one entity on its visibility chain, and recurses on the visible
+   --  part if the entity is an inner package.
 
    function Is_Private_Base_Type (E : Entity_Id) return Boolean;
    --  True for a private type that is not a subtype
@@ -322,9 +329,9 @@ package body Sem_Ch7 is
       Set_Use (Visible_Declarations (Specification (Pack_Decl)));
       Set_Use (Private_Declarations (Specification (Pack_Decl)));
 
-      --  This is a nested package, so it may be necessary to declare
-      --  certain inherited subprograms that are not yet visible because
-      --  the parent type's subprograms are now visible.
+      --  This is a nested package, so it may be necessary to declare certain
+      --  inherited subprograms that are not yet visible because the parent
+      --  type's subprograms are now visible.
 
       if Ekind (Scope (Spec_Id)) = E_Package
         and then Scope (Spec_Id) /= Standard_Standard
@@ -334,6 +341,18 @@ package body Sem_Ch7 is
 
       if Present (Declarations (N)) then
          Analyze_Declarations (Declarations (N));
+         Inspect_Deferred_Constant_Completion (Declarations (N));
+      end if;
+
+      --  Analyze_Declarations has caused freezing of all types; now generate
+      --  bodies for RACW primitives and stream attributes, if any.
+
+      if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then
+
+         --  Attach subprogram bodies to support RACWs declared in spec
+
+         Append_RACW_Bodies (Declarations (N), Spec_Id);
+         Analyze_List (Declarations (N));
       end if;
 
       HSS := Handled_Statement_Sequence (N);
@@ -630,7 +649,15 @@ package body Sem_Ch7 is
 
    procedure Analyze_Package_Declaration (N : Node_Id) is
       Id : constant Node_Id := Defining_Entity (N);
+
       PF : Boolean;
+      --  True when in the context of a declared pure library unit
+
+      Body_Required : Boolean;
+      --  True when this package declaration requires a corresponding body
+
+      Comp_Unit : Boolean;
+      --  True when this package declaration is not a nested declaration
 
    begin
       --  Ada 2005 (AI-217): Check if the package has been erroneously named
@@ -666,18 +693,43 @@ package body Sem_Ch7 is
 
       Analyze (Specification (N));
       Validate_Categorization_Dependency (N, Id);
-      End_Package_Scope (Id);
 
-      --  For a compilation unit, indicate whether it needs a body, and
-      --  whether elaboration warnings may be meaningful on it.
+      Body_Required := Unit_Requires_Body (Id);
+
+      --  When this spec does not require an explicit body, we know that
+      --  there are no entities requiring completion in the language sense;
+      --  we call Check_Completion here only to ensure that any nested package
+      --  declaration that requires an implicit body gets one. (In the case
+      --  where a body is required, Check_Completion is called at the end of
+      --  the body's declarative part.)
+
+      if not Body_Required then
+         Check_Completion;
+      end if;
+
+      Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit;
+      if Comp_Unit then
+
+         --  Set Body_Required indication on the compilation unit node, and
+         --  determine whether elaboration warnings may be meaningful on it.
 
-      if Nkind (Parent (N)) = N_Compilation_Unit then
-         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
+         Set_Body_Required (Parent (N), Body_Required);
 
-         if not Body_Required (Parent (N)) then
+         if not Body_Required then
             Set_Suppress_Elaboration_Warnings (Id);
          end if;
 
+      end if;
+
+      End_Package_Scope (Id);
+
+      --  For the declaration of a library unit that is a remote types package,
+      --  check legality rules regarding availability of stream attributes for
+      --  types that contain non-remote access values. This subprogram performs
+      --  visibility tests that rely on the fact that we have exited the scope
+      --  of Id.
+
+      if Comp_Unit then
          Validate_RT_RAT_Component (N);
       end if;
    end Analyze_Package_Declaration;
@@ -719,11 +771,6 @@ package body Sem_Ch7 is
       --  Child and Unit are entities of compilation units. True if Child
       --  is a public child of Parent as defined in 10.1.1
 
-      procedure Inspect_Deferred_Constant_Completion;
-      --  Examines the deferred constants in the private part of the package
-      --  specification. Emits the error message "constant declaration requires
-      --  initialization expression " if not completed by an Import pragma.
-
       procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
       --  Detects all incomplete or private type declarations having a known
       --  discriminant part that are completed by an Unchecked_Union. Emits
@@ -847,41 +894,6 @@ package body Sem_Ch7 is
          end if;
       end Is_Public_Child;
 
-      ------------------------------------------
-      -- Inspect_Deferred_Constant_Completion --
-      ------------------------------------------
-
-      procedure Inspect_Deferred_Constant_Completion is
-         Decl   : Node_Id;
-
-      begin
-         Decl := First (Priv_Decls);
-         while Present (Decl) loop
-
-            --  Deferred constant signature
-
-            if Nkind (Decl) = N_Object_Declaration
-              and then Constant_Present (Decl)
-              and then No (Expression (Decl))
-
-               --  No need to check internally generated constants
-
-              and then Comes_From_Source (Decl)
-
-               --  The constant is not completed. A full object declaration
-               --  or a pragma Import complete a deferred constant.
-
-              and then not Has_Completion (Defining_Identifier (Decl))
-            then
-               Error_Msg_N
-                 ("constant declaration requires initialization expression",
-                 Defining_Identifier (Decl));
-            end if;
-
-            Decl := Next (Decl);
-         end loop;
-      end Inspect_Deferred_Constant_Completion;
-
       ----------------------------------------
       -- Inspect_Unchecked_Union_Completion --
       ----------------------------------------
@@ -1130,7 +1142,7 @@ package body Sem_Ch7 is
 
          --  Check the private declarations for incomplete deferred constants
 
-         Inspect_Deferred_Constant_Completion;
+         Inspect_Deferred_Constant_Completion (Priv_Decls);
 
          --  The first private entity is the immediate follower of the last
          --  visible entity, if there was one.
@@ -1514,6 +1526,41 @@ package body Sem_Ch7 is
       Set_Homonym     (Full_Id, H2);
    end Exchange_Declarations;
 
+   ------------------------------------------
+   -- Inspect_Deferred_Constant_Completion --
+   ------------------------------------------
+
+   procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
+      Decl   : Node_Id;
+
+   begin
+      Decl := First (Decls);
+      while Present (Decl) loop
+
+         --  Deferred constant signature
+
+         if Nkind (Decl) = N_Object_Declaration
+           and then Constant_Present (Decl)
+           and then No (Expression (Decl))
+
+            --  No need to check internally generated constants
+
+           and then Comes_From_Source (Decl)
+
+            --  The constant is not completed. A full object declaration
+            --  or a pragma Import complete a deferred constant.
+
+           and then not Has_Completion (Defining_Identifier (Decl))
+         then
+            Error_Msg_N
+              ("constant declaration requires initialization expression",
+              Defining_Identifier (Decl));
+         end if;
+
+         Decl := Next (Decl);
+      end loop;
+   end Inspect_Deferred_Constant_Completion;
+
    ----------------------------
    -- Install_Package_Entity --
    ----------------------------
@@ -1723,7 +1770,7 @@ package body Sem_Ch7 is
    begin
       if not Has_Completion (E)
         and then Nkind (P) = N_Package_Declaration
-        and then Present (Activation_Chain_Entity (P))
+        and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E))
       then
          B :=
            Make_Package_Body (Sloc (E),
@@ -1792,7 +1839,7 @@ package body Sem_Ch7 is
          Set_Ekind                (Id, E_Record_Type_With_Private);
          Make_Class_Wide_Type     (Id);
          Set_Primitive_Operations (Id, New_Elmt_List);
-         Set_Is_Abstract          (Id, Abstract_Present (Def));
+         Set_Is_Abstract_Type     (Id, Abstract_Present (Def));
          Set_Is_Limited_Record    (Id, Limited_Present (Def));
          Set_Has_Delayed_Freeze   (Id, True);
 
@@ -1828,13 +1875,16 @@ package body Sem_Ch7 is
 
       begin
          Set_Size_Info (Priv, (Full));
-         Set_RM_Size (Priv, RM_Size (Full));
-         Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
-                                                                      (Full));
-         Set_Is_Volatile        (Priv, Is_Volatile        (Full));
-         Set_Treat_As_Volatile  (Priv, Treat_As_Volatile  (Full));
-         Set_Is_Ada_2005_Only   (Priv, Is_Ada_2005_Only   (Full));
-
+         Set_RM_Size                 (Priv, RM_Size (Full));
+         Set_Size_Known_At_Compile_Time
+                                     (Priv, Size_Known_At_Compile_Time (Full));
+         Set_Is_Volatile             (Priv, Is_Volatile                (Full));
+         Set_Treat_As_Volatile       (Priv, Treat_As_Volatile          (Full));
+         Set_Is_Ada_2005_Only        (Priv, Is_Ada_2005_Only           (Full));
+         Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced    (Full));
+         Set_Has_Pragma_Unreferenced_Objects
+                                     (Priv, Has_Pragma_Unreferenced_Objects
+                                                                       (Full));
          if Is_Unchecked_Union (Full) then
             Set_Is_Unchecked_Union (Base_Type (Priv));
          end if;
@@ -1892,8 +1942,22 @@ package body Sem_Ch7 is
                end if;
             end if;
 
-            Set_First_Entity (Priv, First_Entity (Full));
-            Set_Last_Entity  (Priv, Last_Entity (Full));
+            if Is_Tagged_Type (Priv) then
+
+               --  If the type is tagged, the tag itself must be available
+               --  on the partial view, for expansion purposes.
+
+               Set_First_Entity (Priv, First_Entity (Full));
+
+               --  If there are discriminants in the partial view, these remain
+               --  visible. Otherwise only the tag itself is visible, and there
+               --  are no nameable components in the partial view.
+
+               if No (Last_Entity (Priv)) then
+                  Set_Last_Entity (Priv, First_Entity (Priv));
+               end if;
+            end if;
+
             Set_Has_Discriminants (Priv, Has_Discriminants (Full));
          end if;
       end Preserve_Full_Attributes;
@@ -1905,7 +1969,7 @@ package body Sem_Ch7 is
       function Type_In_Use (T : Entity_Id) return Boolean is
       begin
          return Scope (Base_Type (T)) = P
-           and then  (In_Use (T) or else In_Use (Base_Type (T)));
+           and then (In_Use (T) or else In_Use (Base_Type (T)));
       end Type_In_Use;
 
    --  Start of processing for Uninstall_Declarations
@@ -2206,13 +2270,17 @@ package body Sem_Ch7 is
          then
             null;
 
-         --  Otherwise test to see if entity requires a completion
+         --  Otherwise test to see if entity requires a completion.
+         --  Note that subprogram entities whose declaration does not come
+         --  from source are ignored here on the basis that we assume the
+         --  expander will provide an implicit completion at some point.
 
          elsif (Is_Overloadable (E)
                and then Ekind (E) /= E_Enumeration_Literal
                and then Ekind (E) /= E_Operator
-               and then not Is_Abstract (E)
-               and then not Has_Completion (E))
+               and then not Is_Abstract_Subprogram (E)
+               and then not Has_Completion (E)
+               and then Comes_From_Source (Parent (E)))
 
            or else
              (Ekind (E) = E_Package
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index 44cca27..7615fb8 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -58,9 +58,10 @@ package Sem_Ch7 is
    --  if it contains declarations that require completion in a body.
 
    procedure May_Need_Implicit_Body (E : Entity_Id);
-   --  If a package declaration contains tasks and does not require a
-   --  body, create an implicit body at the end of the current declarative
-   --  part to activate those tasks.
+   --  If a package declaration contains tasks or RACWs and does not require
+   --  a body, create an implicit body at the end of the current declarative
+   --  part to activate those tasks or contain the bodies for the RACW
+   --  calling stubs.
 
    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id);
    --  Common processing for private type declarations and for formal
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index 57998db..9b161a9 100644
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -116,7 +116,7 @@ package body Sem_Dist is
       Primitive_Spec : constant Node_Id :=
                          Copy_Specification (Loc,
                            Spec     => Subp_Spec,
-                           New_Name => Name_Call);
+                           New_Name => Name_uCall);
 
       Subtype_Mark_For_Self : Node_Id;
 
@@ -142,9 +142,8 @@ package body Sem_Dist is
               Subtype_Mark =>
                 Subtype_Mark_For_Self)));
 
-      --  Trick later semantic analysis into considering this
-      --  operation as a primitive (dispatching) operation of
-      --  tagged type Obj_Type.
+      --  Trick later semantic analysis into considering this operation as a
+      --  primitive (dispatching) operation of tagged type Obj_Type.
 
       Set_Comes_From_Source (
         Defining_Unit_Name (Primitive_Spec), True);
@@ -398,45 +397,43 @@ package body Sem_Dist is
    ------------------------------------
 
    procedure Process_Remote_AST_Declaration (N : Node_Id) is
-      Loc            : constant Source_Ptr := Sloc (N);
-      User_Type      : constant Node_Id := Defining_Identifier (N);
-      Scop           : constant Entity_Id := Scope (User_Type);
-      Is_RCI         : constant Boolean :=
-        Is_Remote_Call_Interface (Scop);
-      Is_RT          : constant Boolean :=
-        Is_Remote_Types (Scop);
-      Type_Def       : constant Node_Id := Type_Definition (N);
-
-      Parameter      : Node_Id;
-      Is_Degenerate  : Boolean;
+      Loc       : constant Source_Ptr := Sloc (N);
+      User_Type : constant Node_Id    := Defining_Identifier (N);
+      Scop      : constant Entity_Id  := Scope (User_Type);
+      Is_RCI    : constant Boolean    := Is_Remote_Call_Interface (Scop);
+      Is_RT     : constant Boolean    := Is_Remote_Types (Scop);
+      Type_Def  : constant Node_Id    := Type_Definition (N);
+      Parameter : Node_Id;
+
+      Is_Degenerate : Boolean;
       --  True iff this RAS has an access formal parameter (see
       --  Exp_Dist.Add_RAS_Dereference_TSS for details).
 
-      Subpkg         : constant Entity_Id :=
-                         Make_Defining_Identifier
-                           (Loc, New_Internal_Name ('S'));
-      Subpkg_Decl    : Node_Id;
-      Vis_Decls      : constant List_Id := New_List;
-      Priv_Decls     : constant List_Id := New_List;
+      Subpkg      : constant Entity_Id :=
+                      Make_Defining_Identifier (Loc,
+                        New_Internal_Name ('S'));
+      Subpkg_Decl : Node_Id;
+      Subpkg_Body : Node_Id;
+      Vis_Decls   : constant List_Id := New_List;
+      Priv_Decls  : constant List_Id := New_List;
+
+      Obj_Type : constant Entity_Id :=
+                    Make_Defining_Identifier (Loc,
+                      New_External_Name (Chars (User_Type), 'R'));
 
-      Obj_Type       : constant Entity_Id :=
-                         Make_Defining_Identifier
-                           (Loc, New_External_Name (
-                                   Chars (User_Type), 'R'));
+      Full_Obj_Type : constant Entity_Id :=
+                        Make_Defining_Identifier (Loc,
+                          Chars (Obj_Type));
 
-      Full_Obj_Type  : constant Entity_Id :=
-                         Make_Defining_Identifier
-                           (Loc, Chars (Obj_Type));
+      RACW_Type : constant Entity_Id :=
+                    Make_Defining_Identifier (Loc,
+                      New_External_Name (Chars (User_Type), 'P'));
 
-      RACW_Type      : constant Entity_Id :=
-                         Make_Defining_Identifier
-                           (Loc, New_External_Name (
-                                   Chars (User_Type), 'P'));
+      Fat_Type : constant Entity_Id :=
+                   Make_Defining_Identifier (Loc,
+                     Chars (User_Type));
 
-      Fat_Type       : constant Entity_Id :=
-                        Make_Defining_Identifier
-                          (Loc, Chars (User_Type));
-      Fat_Type_Decl  : Node_Id;
+      Fat_Type_Decl : Node_Id;
 
    begin
       Is_Degenerate := False;
@@ -461,6 +458,7 @@ package body Sem_Dist is
          --  anonymous access type is null, because it cannot be subtype-
          --  conformant with any legal remote subprogram declaration. In this
          --  case, we cannot generate a corresponding primitive operation.
+
       end if;
 
       if Get_PCS_Name = Name_No_DSA then
@@ -493,6 +491,11 @@ package body Sem_Dist is
               Null_Present     => True,
               Component_List   => Empty)));
 
+      --  Trick semantic analysis into swapping the public and full view when
+      --  freezing the public view.
+
+      Set_Comes_From_Source (Full_Obj_Type, True);
+
       if not Is_Degenerate then
          Append_To (Vis_Decls,
            Make_Abstract_Subprogram_Declaration (Loc,
@@ -531,6 +534,19 @@ package body Sem_Dist is
       Set_Is_Remote_Types (Subpkg, Is_RT);
       Insert_After_And_Analyze (N, Subpkg_Decl);
 
+      --  Generate package body to receive RACW calling stubs
+      --  Note: Analyze_Declarations has an absolute requirement that
+      --  the declaration list be non-empty, so we provide a dummy null
+      --  statement here.
+
+      Subpkg_Body :=
+        Make_Package_Body (Loc,
+          Defining_Unit_Name =>
+            Make_Defining_Identifier (Loc, Chars (Subpkg)),
+          Declarations => New_List (
+            Make_Null_Statement (Loc)));
+      Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
+
       --  Many parts of the analyzer and expander expect
       --  that the fat pointer type used to implement remote
       --  access to subprogram types be a record.
@@ -556,7 +572,7 @@ package body Sem_Dist is
                           New_Occurrence_Of (RACW_Type, Loc)))))));
       Set_Equivalent_Type (User_Type, Fat_Type);
       Set_Corresponding_Remote_Type (Fat_Type, User_Type);
-      Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
+      Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
 
       --  The reason we suppress the initialization procedure is that we know
       --  that no initialization is required (even if Initialize_Scalars mode