Patchwork [Ada] DSA code generation reorganization

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 19, 2011, 9:04 a.m.
Message ID <20110919090406.GA25865@adacore.com>
Download mbox | patch
Permalink /patch/115311/
State New
Headers show

Comments

Arnaud Charlet - Sept. 19, 2011, 9:04 a.m.
This change causes the compiler to copy components from runtime record type
System.Partition_Interface.RACW_Stub_Type instead of hard-coding the
component list in Build_Stub_Type. This allows the structure of that type
to be changed in the PCS without having to change the compiler.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-09-19  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb, rtsfind.ads, sem_util.adb, sem_util.ads
	(Build_Stub_Type): Remove, instead copy components from
	System.Partition_Interface.RACW_Stub_Type.
	(RPC_Receiver_Decl): Remainder of code from old Build_Stub_Type routine.
	(Copy_Component_List): New subprogram.

Patch

Index: exp_dist.adb
===================================================================
--- exp_dist.adb	(revision 178955)
+++ exp_dist.adb	(working copy)
@@ -328,8 +328,8 @@ 
 
       RPC_Receiver_Decl : Node_Id;
       --  Declaration for the RPC receiver entity associated with the
-      --  designated type. As an exception, for the case of an RACW that
-      --  implements a RAS, no object RPC receiver is generated. Instead,
+      --  designated type. As an exception, in the case of GARLIC, for an RACW
+      --  that implements a RAS, no object RPC receiver is generated. Instead,
       --  RPC_Receiver_Decl is the declaration after which the RPC receiver
       --  would have been inserted.
 
@@ -559,14 +559,9 @@ 
    --  call. Decls provides a location where variable declarations can be
    --  appended to construct the necessary values.
 
-   procedure Specific_Build_Stub_Type
-     (RACW_Type         : Entity_Id;
-      Stub_Type_Comps   : out List_Id;
-      RPC_Receiver_Decl : out Node_Id);
-   --  Build a components list for the stub type associated with an RACW type,
-   --  and build the necessary RPC receiver, if applicable. PCS-specific
-   --  ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
-   --  is generated, then RPC_Receiver_Decl is set to Empty.
+   function Specific_RPC_Receiver_Decl
+     (RACW_Type : Entity_Id) return Node_Id;
+   --  Build the RPC receiver, for RACW, if applicable, else return Empty
 
    procedure Specific_Build_RPC_Receiver_Body
      (RPC_Receiver : Entity_Id;
@@ -656,10 +651,7 @@ 
          RCI_Locator           : Entity_Id;
          Controlling_Parameter : Entity_Id) return RPC_Target;
 
-      procedure Build_Stub_Type
-        (RACW_Type         : Entity_Id;
-         Stub_Type_Comps   : out List_Id;
-         RPC_Receiver_Decl : out Node_Id);
+      function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
 
       function Build_Subprogram_Receiving_Stubs
         (Vis_Decl                 : Node_Id;
@@ -733,10 +725,7 @@ 
          RCI_Locator           : Entity_Id;
          Controlling_Parameter : Entity_Id) return RPC_Target;
 
-      procedure Build_Stub_Type
-        (RACW_Type         : Entity_Id;
-         Stub_Type_Comps   : out List_Id;
-         RPC_Receiver_Decl : out Node_Id);
+      function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
 
       function Build_Subprogram_Receiving_Stubs
         (Vis_Decl                 : Node_Id;
@@ -1976,7 +1965,6 @@ 
 
       Stub_Elements         : constant Stub_Structure :=
                                 Stubs_Table.Get (Designated_Type);
-      Stub_Type_Comps       : List_Id;
       Stub_Type_Decl        : Node_Id;
       Stub_Type_Access_Decl : Node_Id;
 
@@ -1999,8 +1987,10 @@ 
           Chars => New_External_Name
                      (Related_Id => Chars (Stub_Type), Suffix => 'A'));
 
-      Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+      RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
 
+      --  Create new stub type, copying components from generic RACW_Stub_Type
+
       Stub_Type_Decl :=
         Make_Full_Type_Declaration (Loc,
           Defining_Identifier => Stub_Type,
@@ -2010,7 +2000,8 @@ 
               Limited_Present => True,
               Component_List  =>
                 Make_Component_List (Loc,
-                  Component_Items => Stub_Type_Comps)));
+                  Component_Items =>
+                    Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
 
       --  Does the stub type need to explicitly implement interfaces from the
       --  designated type???
@@ -2041,7 +2032,10 @@ 
 
       if Present (RPC_Receiver_Decl) then
          Append_To (Decls, RPC_Receiver_Decl);
+
       else
+         --  Kludge, requires comment???
+
          RPC_Receiver_Decl := Last (Decls);
       end if;
 
@@ -2399,7 +2393,6 @@ 
           Limited_Present => True,
           Component_List  =>
             Make_Component_List (Loc,
-
               Component_Items => New_List (
                 Make_Component_Declaration (Loc,
                   Defining_Identifier =>
@@ -3874,7 +3867,7 @@ 
             --  Compute distribution identifier
 
             Assign_Subprogram_Identifier
-              (Subp_Def, Current_Subp_Number,  Subp_Val);
+              (Subp_Def, Current_Subp_Number, Subp_Val);
 
             pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
 
@@ -4711,72 +4704,6 @@ 
          return Target_Info;
       end Build_Stub_Target;
 
-      ---------------------
-      -- Build_Stub_Type --
-      ---------------------
-
-      procedure Build_Stub_Type
-        (RACW_Type         : Entity_Id;
-         Stub_Type_Comps   : out List_Id;
-         RPC_Receiver_Decl : out Node_Id)
-      is
-         Loc    : constant Source_Ptr := Sloc (RACW_Type);
-         Is_RAS : constant Boolean    := not Comes_From_Source (RACW_Type);
-
-      begin
-         Stub_Type_Comps := New_List (
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Origin),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => False,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
-
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Receiver),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => False,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Addr),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => False,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Asynchronous),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => False,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (Standard_Boolean, Loc))));
-
-         if Is_RAS then
-            RPC_Receiver_Decl := Empty;
-         else
-            declare
-               RPC_Receiver_Request : constant Entity_Id :=
-                                        Make_Defining_Identifier (Loc, Name_R);
-            begin
-               RPC_Receiver_Decl :=
-                 Make_Subprogram_Declaration (Loc,
-                   Build_RPC_Receiver_Specification
-                     (RPC_Receiver      => Make_Temporary (Loc, 'R'),
-                      Request_Parameter => RPC_Receiver_Request));
-            end;
-         end if;
-      end Build_Stub_Type;
-
       --------------------------------------
       -- Build_Subprogram_Receiving_Stubs --
       --------------------------------------
@@ -5253,6 +5180,28 @@ 
          return Make_Identifier (Loc, Name_V);
       end Result;
 
+      -----------------------
+      -- RPC_Receiver_Decl --
+      -----------------------
+
+      function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
+         Loc    : constant Source_Ptr := Sloc (RACW_Type);
+         Is_RAS : constant Boolean    := not Comes_From_Source (RACW_Type);
+
+      begin
+         --  No RPC receiver for remote access-to-subprogram
+
+         if Is_RAS then
+            return Empty;
+         end if;
+
+         return
+           Make_Subprogram_Declaration (Loc,
+             Build_RPC_Receiver_Specification
+               (RPC_Receiver      => Make_Temporary (Loc, 'R'),
+                Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
+      end RPC_Receiver_Decl;
+
       ----------------------
       -- Stream_Parameter --
       ----------------------
@@ -7659,46 +7608,6 @@ 
          return Target_Info;
       end Build_Stub_Target;
 
-      ---------------------
-      -- Build_Stub_Type --
-      ---------------------
-
-      procedure Build_Stub_Type
-        (RACW_Type         : Entity_Id;
-         Stub_Type_Comps   : out List_Id;
-         RPC_Receiver_Decl : out Node_Id)
-      is
-         Loc : constant Source_Ptr := Sloc (RACW_Type);
-
-      begin
-         Stub_Type_Comps := New_List (
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Target),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present     => False,
-                 Subtype_Indication  =>
-                   New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
-
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_Asynchronous),
-
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => False,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (Standard_Boolean, Loc))));
-
-         RPC_Receiver_Decl :=
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Make_Temporary (Loc, 'R'),
-             Aliased_Present     => True,
-             Object_Definition   =>
-               New_Occurrence_Of (RTE (RE_Servant), Loc));
-      end Build_Stub_Type;
-
       -----------------------------
       -- Build_RPC_Receiver_Body --
       -----------------------------
@@ -11160,6 +11069,21 @@ 
          Overload_Counter_Table.Set (Name_Find, 1);
       end Reserve_NamingContext_Methods;
 
+      -----------------------
+      -- RPC_Receiver_Decl --
+      -----------------------
+
+      function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
+         Loc : constant Source_Ptr := Sloc (RACW_Type);
+
+      begin
+         return
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Make_Temporary (Loc, 'R'),
+             Aliased_Present     => True,
+             Object_Definition   => New_Occurrence_Of (RTE (RE_Servant), Loc));
+      end RPC_Receiver_Decl;
+
    end PolyORB_Support;
 
    -------------------------------
@@ -11514,26 +11438,22 @@ 
       end case;
    end Specific_Build_Stub_Target;
 
-   ------------------------------
-   -- Specific_Build_Stub_Type --
-   ------------------------------
+   --------------------------------
+   -- Specific_RPC_Receiver_Decl --
+   --------------------------------
 
-   procedure Specific_Build_Stub_Type
-     (RACW_Type         : Entity_Id;
-      Stub_Type_Comps   : out List_Id;
-      RPC_Receiver_Decl : out Node_Id)
+   function Specific_RPC_Receiver_Decl
+     (RACW_Type : Entity_Id) return Node_Id
    is
    begin
       case Get_PCS_Name is
          when Name_PolyORB_DSA =>
-            PolyORB_Support.Build_Stub_Type
-              (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+            return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
 
          when others =>
-            GARLIC_Support.Build_Stub_Type
-              (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+            return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
       end case;
-   end Specific_Build_Stub_Type;
+   end Specific_RPC_Receiver_Decl;
 
    -----------------------------------------------
    -- Specific_Build_Subprogram_Receiving_Stubs --
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 178955)
+++ rtsfind.ads	(working copy)
@@ -1163,6 +1163,7 @@ 
      RE_Get_RACW,                        -- System.Partition_Interface
      RE_Get_RCI_Package_Receiver,        -- System.Partition_Interface
      RE_Get_Unique_Remote_Pointer,       -- System.Partition_Interface
+     RE_RACW_Stub_Type,                  -- System.Partition_Interface
      RE_RACW_Stub_Type_Access,           -- System.Partition_Interface
      RE_RAS_Proxy_Type_Access,           -- System.Partition_Interface
      RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
@@ -2357,6 +2358,7 @@ 
      RE_Get_RACW                         => System_Partition_Interface,
      RE_Get_RCI_Package_Receiver         => System_Partition_Interface,
      RE_Get_Unique_Remote_Pointer        => System_Partition_Interface,
+     RE_RACW_Stub_Type                   => System_Partition_Interface,
      RE_RACW_Stub_Type_Access            => System_Partition_Interface,
      RE_RAS_Proxy_Type_Access            => System_Partition_Interface,
      RE_Raise_Program_Error_Unknown_Tag  => System_Partition_Interface,
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 178955)
+++ sem_util.adb	(working copy)
@@ -2265,6 +2265,39 @@ 
    end Conditional_Delay;
 
    -------------------------
+   -- Copy_Component_List --
+   -------------------------
+
+   function Copy_Component_List
+     (R_Typ : Entity_Id;
+      Loc   : Source_Ptr) return List_Id
+   is
+      Comp  : Node_Id;
+      Comps : constant List_Id := New_List;
+   begin
+      Comp := First_Component (Underlying_Type (R_Typ));
+
+      while Present (Comp) loop
+         if Comes_From_Source (Comp) then
+            declare
+               Comp_Decl : constant Node_Id := Declaration_Node (Comp);
+            begin
+               Append_To (Comps,
+                 Make_Component_Declaration (Loc,
+                   Defining_Identifier =>
+                     Make_Defining_Identifier (Loc, Chars (Comp)),
+                   Component_Definition =>
+                     New_Copy_Tree
+                       (Component_Definition (Comp_Decl), New_Sloc => Loc)));
+            end;
+         end if;
+         Next_Component (Comp);
+      end loop;
+
+      return Comps;
+   end Copy_Component_List;
+
+   -------------------------
    -- Copy_Parameter_List --
    -------------------------
 
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 178955)
+++ sem_util.ads	(working copy)
@@ -272,6 +272,13 @@ 
    --  of inlining, and for private protected ops. Also used to create bodies
    --  for stubbed subprograms.
 
+   function Copy_Component_List
+     (R_Typ : Entity_Id;
+      Loc   : Source_Ptr) return List_Id;
+   --  Copy components from record type R_Typ that come from source. Used to
+   --  create a new compatible record type. Loc is the source location assigned
+   --  to the created nodes.
+
    function Current_Entity (N : Node_Id) return Entity_Id;
    pragma Inline (Current_Entity);
    --  Find the currently visible definition for a given identifier, that is to