exp_dist.adb (Add_RAST_Features, [...]): Set the From_Any...

2005-03-29  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Add_RAST_Features, PolyORB version): Set the From_Any,
	To_Any and TypeCode TSSs on RAS types directly using Set_TSS, instead
	of using Set_Renaming_TSS. This ensures that the TSS bodies are not
	analyzed if expansion is disabled (which could otherwise cause spurious
	error messages if expansion has been disabled due to previous
	(unrelated) errors).

	* sem_prag.adb (Analyze_Pragma, case Asynchronous): If RAS expansion
	is disabled, the entity denoted by the argument is the access type
	itself, not an underlying record type, so there is no need to go back
	to the Corresponding_Remote_Type.

From-SVN: r97171

2 files changed, 55 insertions, 128 deletions

diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index f8f34b4..60fdf4f 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -434,11 +434,8 @@ package body Exp_Dist is
 
    procedure Specific_Add_RAST_Features
      (Vis_Decl : Node_Id;
-      RAS_Type : Entity_Id;
-      Decls    : List_Id);
-   --  Add declaration for TSSs for a given RAS type. The declarations are
-   --  added just after the declaration of the RAS type itself, while the
-   --  bodies are inserted at the end of Decls. PCS-specific ancillary
+      RAS_Type : Entity_Id);
+   --  Add declaration for TSSs for a given RAS type. PCS-specific ancillary
    --  subprogram for Add_RAST_Features.
 
    --  An RPC_Target record is used during construction of calling stubs
@@ -576,8 +573,7 @@ package body Exp_Dist is
 
       procedure Add_RAST_Features
         (Vis_Decl : Node_Id;
-         RAS_Type : Entity_Id;
-         Decls    : List_Id);
+         RAS_Type : Entity_Id);
 
       procedure Build_General_Calling_Stubs
         (Decls                     : List_Id;
@@ -652,8 +648,7 @@ package body Exp_Dist is
 
       procedure Add_RAST_Features
         (Vis_Decl : Node_Id;
-         RAS_Type : Entity_Id;
-         Decls    : List_Id);
+         RAS_Type : Entity_Id);
 
       procedure Build_General_Calling_Stubs
         (Decls                     : List_Id;
@@ -1711,20 +1706,10 @@ package body Exp_Dist is
    procedure Add_RAST_Features (Vis_Decl : Node_Id) is
       RAS_Type : constant Entity_Id :=
                    Equivalent_Type (Defining_Identifier (Vis_Decl));
-
-      Spec  : constant Node_Id :=
-                Specification (Unit (Enclosing_Lib_Unit_Node (Vis_Decl)));
-      Decls : List_Id := Private_Declarations (Spec);
-
    begin
       pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
-
-      if No (Decls) then
-         Decls := Visible_Declarations (Spec);
-      end if;
-
       Add_RAS_Dereference_TSS (Vis_Decl);
-      Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls);
+      Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
    end Add_RAST_Features;
 
    -------------------
@@ -3266,11 +3251,10 @@ package body Exp_Dist is
 
       procedure Add_RAST_Features
         (Vis_Decl : Node_Id;
-         RAS_Type : Entity_Id;
-         Decls    : List_Id)
+         RAS_Type : Entity_Id)
       is
          pragma Warnings (Off);
-         pragma Unreferenced (RAS_Type, Decls);
+         pragma Unreferenced (RAS_Type);
          pragma Warnings (On);
       begin
          Add_RAS_Access_TSS (Vis_Decl);
@@ -5094,19 +5078,13 @@ package body Exp_Dist is
          Declarations    : List_Id);
       --  Add the TypeCode TSS for this RACW type
 
-      procedure Add_RAS_From_Any
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id);
+      procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
       --  Add the From_Any TSS for this RAS type
 
-      procedure Add_RAS_To_Any
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id);
+      procedure Add_RAS_To_Any   (RAS_Type : Entity_Id);
       --  Add the To_Any TSS for this RAS type
 
-      procedure Add_RAS_TypeCode
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id);
+      procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
       --  Add the TypeCode TSS for this RAS type
 
       procedure Add_RAS_Access_TSS (N : Node_Id);
@@ -5940,18 +5918,17 @@ package body Exp_Dist is
 
       procedure Add_RAST_Features
         (Vis_Decl : Node_Id;
-         RAS_Type : Entity_Id;
-         Decls    : List_Id)
+         RAS_Type : Entity_Id)
       is
       begin
          Add_RAS_Access_TSS (Vis_Decl);
 
-         Add_RAS_From_Any (RAS_Type, Decls);
-         Add_RAS_TypeCode (RAS_Type, Decls);
+         Add_RAS_From_Any (RAS_Type);
+         Add_RAS_TypeCode (RAS_Type);
 
          --  To_Any uses TypeCode, and therefore needs to be generated last
 
-         Add_RAS_To_Any (RAS_Type, Decls);
+         Add_RAS_To_Any   (RAS_Type);
       end Add_RAST_Features;
 
       ------------------------
@@ -6289,18 +6266,13 @@ package body Exp_Dist is
       -- Add_RAS_From_Any --
       ----------------------
 
-      procedure Add_RAS_From_Any
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id)
-      is
+      procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
          Loc : constant Source_Ptr := Sloc (RAS_Type);
 
-         Fnam : constant Entity_Id :=
-                  Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
+         Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
+                  Make_TSS_Name (RAS_Type, TSS_From_Any));
 
          Func_Spec : Node_Id;
-         Func_Decl : Node_Id;
-         Func_Body : Node_Id;
 
          Statements : List_Id;
 
@@ -6334,45 +6306,30 @@ package body Exp_Dist is
                    New_Occurrence_Of (RTE (RE_Any), Loc))),
              Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc));
 
-         --  NOTE: The usage occurrences of RACW_Parameter must
-         --  refer to the entity in the declaration spec, not those
-         --  of the body spec.
-
-         Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
-
-         Func_Body :=
+         Discard_Node (
            Make_Subprogram_Body (Loc,
-             Specification              =>
-               Copy_Specification (Loc, Func_Spec),
+             Specification              => Func_Spec,
              Declarations               => No_List,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements => Statements));
-
-         Insert_After (Declaration_Node (RAS_Type), Func_Decl);
-         Append_To (Declarations, Func_Body);
-
-         Set_Renaming_TSS (RAS_Type, Fnam, TSS_From_Any);
+                 Statements => Statements)));
+         Set_TSS (RAS_Type, Fnam);
       end Add_RAS_From_Any;
 
       --------------------
       -- Add_RAS_To_Any --
       --------------------
 
-      procedure Add_RAS_To_Any
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id)
-      is
+      procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
          Loc : constant Source_Ptr := Sloc (RAS_Type);
 
-         Fnam : Entity_Id;
+         Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
+                  Make_TSS_Name (RAS_Type, TSS_To_Any));
 
-         Decls : List_Id;
+         Decls      : List_Id;
          Statements : List_Id;
 
          Func_Spec : Node_Id;
-         Func_Decl : Node_Id;
-         Func_Body : Node_Id;
 
          Any            : constant Entity_Id :=
                             Make_Defining_Identifier (Loc,
@@ -6411,9 +6368,6 @@ package body Exp_Dist is
              Expression =>
                New_Occurrence_Of (Any, Loc)));
 
-         Fnam := Make_Defining_Identifier (
-           Loc, New_Internal_Name ('T'));
-
          Func_Spec :=
            Make_Function_Specification (Loc,
              Defining_Unit_Name =>
@@ -6426,42 +6380,27 @@ package body Exp_Dist is
                    New_Occurrence_Of (RAS_Type, Loc))),
              Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
 
-         --  NOTE: The usage occurrences of RAS_Parameter must
-         --  refer to the entity in the declaration spec, not in
-         --  the body spec.
-
-         Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
-
-         Func_Body :=
+         Discard_Node (
            Make_Subprogram_Body (Loc,
-             Specification              =>
-               Copy_Specification (Loc, Func_Spec),
+             Specification              => Func_Spec,
              Declarations               => Decls,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements => Statements));
-
-         Insert_After (Declaration_Node (RAS_Type), Func_Decl);
-         Append_To (Declarations, Func_Body);
-
-         Set_Renaming_TSS (RAS_Type, Fnam, TSS_To_Any);
+                 Statements => Statements)));
+         Set_TSS (RAS_Type, Fnam);
       end Add_RAS_To_Any;
 
       ----------------------
       -- Add_RAS_TypeCode --
       ----------------------
 
-      procedure Add_RAS_TypeCode
-        (RAS_Type     : Entity_Id;
-         Declarations : List_Id)
-      is
+      procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
          Loc : constant Source_Ptr := Sloc (RAS_Type);
 
-         Fnam : Entity_Id;
+         Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
+                  Make_TSS_Name (RAS_Type, TSS_TypeCode));
 
          Func_Spec : Node_Id;
-         Func_Decl : Node_Id;
-         Func_Body : Node_Id;
 
          Decls : constant List_Id := New_List;
          Name_String, Repo_Id_String : String_Id;
@@ -6470,11 +6409,6 @@ package body Exp_Dist is
                            Make_Defining_Identifier (Loc, Name_R);
 
       begin
-
-         Fnam :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_Internal_Name ('T'));
-
          --  The spec for this subprogram has a dummy 'access RAS'
          --  argument, which serves only for overloading purposes.
 
@@ -6491,19 +6425,12 @@ package body Exp_Dist is
                      Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))),
              Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
 
-         --  NOTE: The usage occurrences of RAS_Parameter must
-         --  refer to the entity in the declaration spec, not those
-         --  of the body spec.
-
-         Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
-
          PolyORB_Support.Helpers.Build_Name_And_Repository_Id
            (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
 
-         Func_Body :=
+         Discard_Node (
            Make_Subprogram_Body (Loc,
-             Specification              =>
-               Copy_Specification (Loc, Func_Spec),
+             Specification              => Func_Spec,
              Declarations               => Decls,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
@@ -6528,12 +6455,8 @@ package body Exp_Dist is
                                      RTE (RE_TA_String), Loc),
                                    Parameter_Associations => New_List (
                                      Make_String_Literal (Loc,
-                                       Repo_Id_String)))))))))));
-
-         Insert_After (Declaration_Node (RAS_Type), Func_Decl);
-         Append_To (Declarations, Func_Body);
-
-         Set_Renaming_TSS (RAS_Type, Fnam, TSS_TypeCode);
+                                       Repo_Id_String))))))))))));
+         Set_TSS (RAS_Type, Fnam);
       end Add_RAS_TypeCode;
 
       -----------------------------------------
@@ -10783,17 +10706,13 @@ package body Exp_Dist is
 
    procedure Specific_Add_RAST_Features
      (Vis_Decl : Node_Id;
-      RAS_Type : Entity_Id;
-      Decls    : List_Id)
-   is
+      RAS_Type : Entity_Id) is
    begin
       case Get_PCS_Name is
          when Name_PolyORB_DSA =>
-            PolyORB_Support.Add_RAST_Features (
-              Vis_Decl, RAS_Type, Decls);
+            PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
          when others =>
-            GARLIC_Support.Add_RAST_Features (
-              Vis_Decl, RAS_Type, Decls);
+            GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
       end case;
    end Specific_Add_RAST_Features;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index b301929..a65c9ca 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -55,6 +55,7 @@ with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
 with Sem_Elim; use Sem_Elim;
 with Sem_Eval; use Sem_Eval;
 with Sem_Intr; use Sem_Intr;
@@ -4605,13 +4606,20 @@ package body Sem_Prag is
                Error_Pragma_Arg
                  ("pragma% cannot be applied to function", Arg1);
 
-            elsif Ekind (Nm) = E_Record_Type
-              and then Present (Corresponding_Remote_Type (Nm))
-            then
-               --  A record type that is the Equivalent_Type for
-               --  a remote access-to-subprogram type.
+            elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
+
+               if Is_Record_Type (Nm) then
+                  --  A record type that is the Equivalent_Type for
+                  --  a remote access-to-subprogram type.
+
+                  N := Declaration_Node (Corresponding_Remote_Type (Nm));
 
-               N := Declaration_Node (Corresponding_Remote_Type (Nm));
+               else
+                  --  A non-expanded RAS type (case where distribution is
+                  --  not enabled).
+
+                  N := Declaration_Node (Nm);
+               end if;
 
                if Nkind (N) = N_Full_Type_Declaration
                  and then Nkind (Type_Definition (N)) =
@@ -4622,9 +4630,9 @@ package body Sem_Prag is
 
                   if Is_Asynchronous (Nm)
                     and then Expander_Active
+                    and then Get_PCS_Name /= Name_No_DSA
                   then
-                     RACW_Type_Is_Asynchronous (
-                       Underlying_RACW_Type (Nm));
+                     RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
                   end if;
 
                else