exp_dist.adb: Split declaration of asynchronous flag out of Add_RACW_Read_Attribute.

2004-10-04  Thomas Quinot  <quinot@act-europe.fr>

	* exp_dist.adb: Split declaration of asynchronous flag out of
	Add_RACW_Read_Attribute.
	Minor reformatting for better alignment with PolyORB version.
	Store the entity for the asynchronous flag of an RACW, rather than the
	expression, in the asynchronous flags table. This will allow this flag
	to be used in other subprograms beside Add_RACW_Read_Attribute.

From-SVN: r88486

2 files changed, 107 insertions, 60 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6620e37..48ffeb9 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,14 @@
 2004-10-04  Thomas Quinot  <quinot@act-europe.fr>
 
+	* exp_dist.adb: Split declaration of asynchronous flag out of
+	Add_RACW_Read_Attribute.
+	Minor reformatting for better alignment with PolyORB version.
+	Store the entity for the asynchronous flag of an RACW, rather than the
+	expression, in the asynchronous flags table. This will allow this flag
+	to be used in other subprograms beside Add_RACW_Read_Attribute.
+
+2004-10-04  Thomas Quinot  <quinot@act-europe.fr>
+
 	* g-socket.ads, g-socket.adb, g-socthi.adb, socket.c,
 	g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads, 
 	g-soccon-interix.ads, g-soccon-solaris.ads, g-soccon-vms.adb, 
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 7015079..e52483f 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -131,7 +131,7 @@ package body Exp_Dist is
       Is_Known_Non_Asynchronous : Boolean := False;
       Is_Function               : Boolean;
       Spec                      : Node_Id;
-      Object_Type               : Entity_Id := Empty;
+      Stub_Type                 : Entity_Id := Empty;
       Nod                       : Node_Id);
    --  Build calling stubs for general purpose. The parameters are:
    --    Decls             : a place to put declarations
@@ -147,10 +147,10 @@ package body Exp_Dist is
    --    Is_Known_Non_A... : True if we know that this is not asynchronous
    --    Spec              : a node with a Parameter_Specifications and
    --                        a Subtype_Mark if applicable
-   --    Object_Type       : in case of a RACW, parameters of type access to
-   --                        Object_Type will be marshalled using the
-   --                        address of this object (the addr field) rather
-   --                        than using the 'Write on the object itself
+   --    Stub_Type         : in case of RACW stubs, parameters of type access
+   --                        to Stub_Type will be marshalled using the
+   --                        address of the object (the addr field) rather
+   --                        than using the 'Write on the stub itself
    --    Nod               : used to provide sloc for generated code
 
    function Build_Subprogram_Calling_Stubs
@@ -292,13 +292,13 @@ package body Exp_Dist is
 
    package Asynchronous_Flags_Table is
       new Simple_HTable (Header_Num => Hash_Index,
-                         Element    => Node_Id,
+                         Element    => Entity_Id,
                          No_Element => Empty,
                          Key        => Entity_Id,
                          Hash       => Hash,
                          Equal      => "=");
-   --  Mapping between a RACW type and the node holding the value True if
-   --  the RACW is asynchronous and False otherwise.
+   --  Mapping between a RACW type and a constant having the value True
+   --  if the RACW is asynchronous and False otherwise.
 
    package RCI_Locator_Table is
       new Simple_HTable (Header_Num => Hash_Index,
@@ -332,6 +332,12 @@ package body Exp_Dist is
    --  then nothing is added in the tree but the right values are returned
    --  anyhow and Existing is set to True.
 
+   procedure Add_RACW_Asynchronous_Flag
+     (Declarations : List_Id;
+      RACW_Type    : Entity_Id);
+   --  Declare a boolean constant associated with RACW_Type whose value
+   --  indicates at run time whether a pragma Asynchronous applies to it.
+
    procedure Add_RACW_Read_Attribute
      (RACW_Type           : Entity_Id;
       Stub_Type           : Entity_Id;
@@ -470,6 +476,34 @@ package body Exp_Dist is
       end loop;
    end Add_Calling_Stubs_To_Declarations;
 
+   --------------------------------
+   -- Add_RACW_Asynchronous_Flag --
+   --------------------------------
+
+   procedure Add_RACW_Asynchronous_Flag
+     (Declarations : List_Id;
+      RACW_Type    : Entity_Id)
+   is
+      Loc : constant Source_Ptr := Sloc (RACW_Type);
+
+      Asynchronous_Flag : constant Entity_Id :=
+                            Make_Defining_Identifier (Loc,
+                              New_External_Name (Chars (RACW_Type), 'A'));
+
+   begin
+      --  Declare the asynchronous flag. This flag will be changed to True
+      --  whenever it is known that the RACW type is asynchronous.
+
+      Append_To (Declarations,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Asynchronous_Flag,
+          Constant_Present    => True,
+          Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
+          Expression          => New_Occurrence_Of (Standard_False, Loc)));
+
+      Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
+   end Add_RACW_Asynchronous_Flag;
+
    -----------------------
    -- Add_RACW_Features --
    -----------------------
@@ -527,6 +561,10 @@ package body Exp_Dist is
          Object_RPC_Receiver => Object_RPC_Receiver,
          Existing            => Existing);
 
+      Add_RACW_Asynchronous_Flag
+        (Declarations        => Decls,
+         RACW_Type           => RACW_Type);
+
       Add_RACW_Read_Write_Attributes
         (RACW_Type           => RACW_Type,
          Stub_Type           => Stub_Type,
@@ -537,9 +575,8 @@ package body Exp_Dist is
       if not Same_Scope and then not Existing then
 
          --  The RACW has been declared in another scope than the designated
-         --  type and has not been handled by another RACW in the same
-         --  package as the first one, so add primitive for the stub type
-         --  here.
+         --  type and has not been handled by another RACW in the same package
+         --  as the first one, so add primitive for the stub type here.
 
          Add_RACW_Primitive_Declarations_And_Bodies
            (Designated_Type  => Desig,
@@ -561,9 +598,8 @@ package body Exp_Dist is
       Insertion_Node  : Node_Id;
       Decls           : List_Id)
    is
-      --  Set sloc of generated declaration to be that of the
-      --  insertion node, so the declarations are recognized as
-      --  belonging to the current package.
+      --  Set sloc of generated declaration copy of insertion node sloc, so
+      --  the declarations are recognized as belonging to the current package.
 
       Loc : constant Source_Ptr := Sloc (Insertion_Node);
 
@@ -789,50 +825,42 @@ package body Exp_Dist is
       Source_Address    : constant Entity_Id :=
                             Make_Defining_Identifier
                               (Loc, New_Internal_Name ('P'));
-      Local_Stub        : constant Entity_Id  :=
+      Local_Stub        : constant Entity_Id :=
                             Make_Defining_Identifier
                               (Loc, New_Internal_Name ('L'));
-      Stubbed_Result    : constant Entity_Id  :=
+      Stubbed_Result    : constant Entity_Id :=
                             Make_Defining_Identifier
                               (Loc, New_Internal_Name ('S'));
       Asynchronous_Flag : constant Entity_Id :=
-                            Make_Defining_Identifier
-                              (Loc, New_Internal_Name ('S'));
-      Asynchronous_Node : constant Node_Id   :=
-                            New_Occurrence_Of (Standard_False, Loc);
-
-      --  Functions to create occurrences of the formal
-      --  parameter names.
+                            Asynchronous_Flags_Table.Get (RACW_Type);
+      pragma Assert (Present (Asynchronous_Flag));
 
       function Stream_Parameter return Node_Id;
       function Result return Node_Id;
+      --  Functions to create occurrences of the formal parameter names
 
-      function Stream_Parameter return Node_Id is
-      begin
-         return Make_Identifier (Loc, Name_S);
-      end Stream_Parameter;
+      ------------
+      -- Result --
+      ------------
 
       function Result return Node_Id is
       begin
          return Make_Identifier (Loc, Name_V);
       end Result;
 
-   begin
-      --  Declare the asynchronous flag. This flag will be changed to True
-      --  whenever it is known that the RACW type is asynchronous. Also, the
-      --  node gets stored since it may be rewritten when we process the
-      --  asynchronous pragma.
+      ----------------------
+      -- Stream_Parameter --
+      ----------------------
 
-      Append_To (Declarations,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Asynchronous_Flag,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
-          Expression          => Asynchronous_Node));
+      function Stream_Parameter return Node_Id is
+      begin
+         return Make_Identifier (Loc, Name_S);
+      end Stream_Parameter;
 
-      Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
+   --  Start of processing for Add_RACW_Read_Attribute
 
-      --  Object declarations
+   begin
+      --  Generate object declarations
 
       Decls := New_List (
         Make_Object_Declaration (Loc,
@@ -1374,17 +1402,19 @@ package body Exp_Dist is
               Attribute_Name => Name_Unchecked_Access)));
 
       Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
-      --  Build_Get_Unique_RP_Call needs this information.
+      --  Build_Get_Unique_RP_Call needs this information
 
       --  Note: Here we assume that the Fat_Type is a record
       --  containing just a pointer to a proxy or stub object.
 
       Proc_Statements := New_List (
 
-      --  Get_RAS_Info (Pkg, Subp, PA);
-      --  if Origin = Local_Partition_Id and then not All_Calls_Remote then
-      --     return Fat_Type!(PA);
-      --  end if;
+      --  Generate:
+
+      --    Get_RAS_Info (Pkg, Subp, PA);
+      --    if Origin = Local_Partition_Id and then not All_Calls_Remote then
+      --       return Fat_Type!(PA);
+      --    end if;
 
          Make_Procedure_Call_Statement (Loc,
            Name =>
@@ -1426,16 +1456,18 @@ package body Exp_Dist is
 
         Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
 
+      --  E.4.1(9) A remote call is asynchronous if it is a call to
+      --  a procedure, or a call through a value of an access-to-procedure
+      --  type, to which a pragma Asynchronous applies.
+
+      --    Parameter Asynch_P is true when the procedure is asynchronous;
+      --    Expression Asynch_T is true when the type is asynchronous.
+
         Set_Field (Name_Asynchronous,
           Make_Or_Else (Loc,
             New_Occurrence_Of (Asynch_P, Loc),
             New_Occurrence_Of (Boolean_Literals (
               Is_Asynchronous (Ras_Type)), Loc))));
-      --  E.4.1(9) A remote call is asynchronous if it is a call to
-      --  a procedure, or a call through a value of an access-to-procedure
-      --  type, to which a pragma Asynchronous applies.
-      --  Parameter Asynch_P is true when the procedure is asynchronous;
-      --  Expression Asynch_T is true when the type is asynchronous.
 
       Append_List_To (Proc_Statements,
         Build_Get_Unique_RP_Call
@@ -1497,6 +1529,8 @@ package body Exp_Dist is
    -- Add_RAS_Dereference_TSS --
    -----------------------------
 
+   --  This subprogram could use more comments ???
+
    procedure Add_RAS_Dereference_TSS (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
 
@@ -1611,7 +1645,7 @@ package body Exp_Dist is
              Parameter_Associations => Param_Assoc));
       end if;
 
-      --  Build the complete subprogram.
+      --  Build the complete subprogram
 
       if Is_Function then
          Proc_Spec :=
@@ -1745,7 +1779,6 @@ package body Exp_Dist is
 
       Set_Comes_From_Source (Proxy_Type_Full_View, True);
 
-
       --  procedure Call
       --    (Self : access O;
       --     ...other-formals...) is
@@ -1919,6 +1952,10 @@ package body Exp_Dist is
       --  associating Subprogram_Number with the subprogram declared
       --  by Declaration, for which we have receiving stubs in Stubs.
 
+      ---------------------
+      -- Append_Stubs_To --
+      ---------------------
+
       procedure Append_Stubs_To
         (RPC_Receiver_Cases : List_Id;
          Declaration        : Node_Id;
@@ -2435,7 +2472,7 @@ package body Exp_Dist is
       Is_Known_Non_Asynchronous : Boolean   := False;
       Is_Function               : Boolean;
       Spec                      : Node_Id;
-      Object_Type               : Entity_Id := Empty;
+      Stub_Type                 : Entity_Id := Empty;
       Nod                       : Node_Id)
    is
       Loc : constant Source_Ptr := Sloc (Nod);
@@ -2459,7 +2496,7 @@ package body Exp_Dist is
 
       Asynchronous_Statements     : List_Id := No_List;
       Non_Asynchronous_Statements : List_Id := No_List;
-      --  Statements specifics to the Asynchronous/Non-Asynchronous cases.
+      --  Statements specifics to the Asynchronous/Non-Asynchronous cases
 
       Extra_Formal_Statements : constant List_Id := New_List;
       --  List of statements for extra formal parameters. It will appear after
@@ -2575,7 +2612,7 @@ package body Exp_Dist is
             Extra_Parameter : Entity_Id;
 
          begin
-            if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
+            if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
 
                --  In the case of a controlling formal argument, we marshall
                --  its addr field rather than the local stub.
@@ -2802,7 +2839,7 @@ package body Exp_Dist is
 
                   if (Out_Present (Current_Parameter)
                        or else Nkind (Typ) = N_Access_Definition)
-                    and then Etyp /= Object_Type
+                    and then Etyp /= Stub_Type
                   then
                      Append_To (Non_Asynchronous_Statements,
                         Make_Attribute_Reference (Loc,
@@ -3287,7 +3324,7 @@ package body Exp_Dist is
          Is_Function           => Nkind (Spec_To_Use) =
                                     N_Function_Specification,
          Spec                  => Spec_To_Use,
-         Object_Type           => Stub_Type,
+         Stub_Type             => Stub_Type,
          Nod                   => Vis_Decl);
 
       RCI_Calling_Stubs_Table.Set
@@ -4279,10 +4316,11 @@ package body Exp_Dist is
    -------------------------------
 
    procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
-      N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
-      pragma Assert (N /= Empty);
+      Asynchronous_Flag : constant Entity_Id :=
+                           Asynchronous_Flags_Table.Get (RACW_Type);
    begin
-      Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
+      Replace (Expression (Parent (Asynchronous_Flag)),
+        New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
    end RACW_Type_Is_Asynchronous;
 
    -------------------------