exp_smem.ads, [...]: Construction of access and assign routines has been replaced by an...

2008-05-20  Kevin Pouget  <pouget@adacore.com>

	* exp_smem.ads, exp_smem.adb: Construction of access and assign
	routines has been replaced by an instantiation of
	System.Shared_Storage.Shared_Var_Procs generic package, while expanding
	shared variable declaration.
	Calls to access and assign routines have been replaced by calls to
	Read/Write routines of System.Shared_Storage.Shared_Var_Procs
	instantiated package.
	
	* rtsfind.ads: RE_Shared_Var_Procs entry has been added in RE_Unit_Table
	It identifies the new generic package added in s-shasto.

	* s-shasto.adb, s-shasto.ads: A new generic package has been added, it
	is instantiated for each shared passive variable. It provides
	supporting procedures called upon each read or write access by the
	expanded code.

	* sem_attr.adb:
	For this runtime unit (always compiled in GNAT mode), we allow
	stream attributes references for limited types for the case where
	shared passive objects are implemented using stream attributes,
	which is the default in GNAT's persistent storage implementation.

From-SVN: r135627

6 files changed, 165 insertions, 209 deletions

diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb
index ae1ea9b..0e3fc23 100644
--- a/gcc/ada/exp_smem.adb
+++ b/gcc/ada/exp_smem.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2008, 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- --
@@ -71,6 +71,29 @@ package body Exp_Smem is
    --  OUT or IN OUT parameter to a procedure call. If the result is
    --  True, then Insert_Node is set to point to the call.
 
+   function Build_Shared_Var_Proc_Call
+     (Loc : Source_Ptr;
+      E   : Node_Id;
+      N   : Name_Id) return Node_Id;
+   --  Build a call to support procedure N for shared object E (provided by
+   --  the instance of System.Shared_Storage.Shared_Var_Procs associated to E).
+
+   --------------------------------
+   -- Build_Shared_Var_Proc_Call --
+   --------------------------------
+
+   function Build_Shared_Var_Proc_Call
+     (Loc : Source_Ptr;
+      E   : Entity_Id;
+      N   : Name_Id) return Node_Id is
+   begin
+      return Make_Procedure_Call_Statement (Loc,
+        Name => Make_Selected_Component (Loc,
+          Prefix        =>
+            New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
+          Selector_Name => Make_Identifier (Loc, Chars => N)));
+   end Build_Shared_Var_Proc_Call;
+
    ---------------------
    -- Add_Read_Before --
    ---------------------
@@ -78,14 +101,9 @@ package body Exp_Smem is
    procedure Add_Read_Before (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
       Ent : constant Node_Id    := Entity (N);
-
    begin
-      if Present (Shared_Var_Read_Proc (Ent)) then
-         Insert_Action (N,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
-             Parameter_Associations => Empty_List));
+      if Present (Shared_Var_Procs_Instance (Ent)) then
+         Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read));
       end if;
    end Add_Read_Before;
 
@@ -134,8 +152,7 @@ package body Exp_Smem is
       --  Now, right after the Lock, insert a call to read the object
 
       Insert_Before_And_Analyze (Inode,
-        Make_Procedure_Call_Statement (Loc,
-          Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
+        Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
 
       --  Now insert the Unlock call after
 
@@ -150,8 +167,7 @@ package body Exp_Smem is
 
       if Nkind (N) = N_Procedure_Call_Statement then
          Insert_After_And_Analyze (Inode,
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
+           Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
       end if;
 
    end Add_Shared_Var_Lock_Procs;
@@ -165,12 +181,9 @@ package body Exp_Smem is
       Ent : constant Node_Id    := Entity (N);
 
    begin
-      if Present (Shared_Var_Assign_Proc (Ent)) then
+      if Present (Shared_Var_Procs_Instance (Ent)) then
          Insert_After_And_Analyze (Insert_Node,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
-             Parameter_Associations => Empty_List));
+           Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
       end if;
    end Add_Write_After;
 
@@ -276,21 +289,18 @@ package body Exp_Smem is
       Ent : constant Entity_Id  := Defining_Identifier (N);
       Typ : constant Entity_Id  := Etype (Ent);
       Vnm : String_Id;
-      Atr : Node_Id;
 
       After : constant Node_Id := Next (N);
       --  Node located right after N originally (after insertion of the SV
       --  procs this node is right after the last inserted node).
 
-      Assign_Proc : constant Entity_Id :=
-                      Make_Defining_Identifier (Loc,
-                        Chars => New_External_Name (Chars (Ent), 'A'));
-
-      Read_Proc : constant Entity_Id :=
-                    Make_Defining_Identifier (Loc,
-                      Chars => New_External_Name (Chars (Ent), 'R'));
+      SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
+                       Chars => New_External_Name (Chars (Ent), 'G'));
+      --  Instance of System.Shared_Storage.Shared_Var_Procs associated
+      --  with Ent.
 
-      S : Entity_Id;
+      Instantiation : Node_Id;
+      --  Package instanciation node for SVP_Instance
 
    --  Start of processing for Make_Shared_Var_Procs
 
@@ -298,149 +308,33 @@ package body Exp_Smem is
       Build_Full_Name (Ent, Vnm);
 
       --  We turn off Shared_Passive during construction and analysis of
-      --  the assign and read routines, to avoid improper attempts to
-      --  process the variable references within these procedures.
+      --  the generic package instantition, to avoid improper attempts to
+      --  process the variable references within these instantiation.
 
       Set_Is_Shared_Passive (Ent, False);
 
-      --  Construct assignment routine
-
-      --    procedure VarA is
-      --       S : Ada.Streams.Stream_IO.Stream_Access;
-      --    begin
-      --       S := Shared_Var_WOpen ("pkg.var");
-      --       typ'Write (S, var);
-      --       Shared_Var_Close (S);
-      --    end VarA;
-
-      S   := Make_Defining_Identifier (Loc, Name_uS);
-
-      Atr :=
-        Make_Attribute_Reference (Loc,
-          Prefix => New_Occurrence_Of (Typ, Loc),
-          Attribute_Name => Name_Write,
-          Expressions => New_List (
-            New_Reference_To (S, Loc),
-            New_Occurrence_Of (Ent, Loc)));
-
-      Insert_After_And_Analyze (N,
-        Make_Subprogram_Body (Loc,
-          Specification =>
-            Make_Procedure_Specification (Loc,
-              Defining_Unit_Name => Assign_Proc),
-
-         --  S : Ada.Streams.Stream_IO.Stream_Access;
-
-          Declarations => New_List (
-            Make_Object_Declaration (Loc,
-              Defining_Identifier => S,
-              Object_Definition =>
-                New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
-
-          Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => New_List (
-
-               --  S := Shared_Var_WOpen ("pkg.var");
-
-                Make_Assignment_Statement (Loc,
-                  Name => New_Reference_To (S, Loc),
-                  Expression =>
-                    Make_Function_Call (Loc,
-                      Name =>
-                        New_Occurrence_Of
-                          (RTE (RE_Shared_Var_WOpen), Loc),
-                      Parameter_Associations => New_List (
-                        Make_String_Literal (Loc, Vnm)))),
-
-                Atr,
-
-               --  Shared_Var_Close (S);
-
-                Make_Procedure_Call_Statement (Loc,
-                  Name =>
-                    New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
-                  Parameter_Associations =>
-                    New_List (New_Reference_To (S, Loc)))))));
-
-      --  Construct read routine
-
-      --    procedure varR is
-      --       S : Ada.Streams.Stream_IO.Stream_Access;
-      --    begin
-      --       S := Shared_Var_ROpen ("pkg.var");
-      --       if S /= null then
-      --          typ'Read (S, Var);
-      --          Shared_Var_Close (S);
-      --       end if;
-      --    end varR;
-
-      S   := Make_Defining_Identifier (Loc, Name_uS);
-
-      Atr :=
-        Make_Attribute_Reference (Loc,
-          Prefix => New_Occurrence_Of (Typ, Loc),
-          Attribute_Name => Name_Read,
-          Expressions => New_List (
-            New_Reference_To (S, Loc),
-            New_Occurrence_Of (Ent, Loc)));
-
-      Insert_After_And_Analyze (N,
-        Make_Subprogram_Body (Loc,
-          Specification =>
-            Make_Procedure_Specification (Loc,
-              Defining_Unit_Name => Read_Proc),
-
-         --  S : Ada.Streams.Stream_IO.Stream_Access;
-
-          Declarations => New_List (
-            Make_Object_Declaration (Loc,
-              Defining_Identifier => S,
-              Object_Definition =>
-                New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
-
-          Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => New_List (
-
-               --  S := Shared_Var_ROpen ("pkg.var");
-
-                Make_Assignment_Statement (Loc,
-                  Name => New_Reference_To (S, Loc),
-                  Expression =>
-                    Make_Function_Call (Loc,
-                      Name =>
-                        New_Occurrence_Of
-                          (RTE (RE_Shared_Var_ROpen), Loc),
-                      Parameter_Associations => New_List (
-                        Make_String_Literal (Loc, Vnm)))),
-
-               --  if S /= null then
-
-                Make_Implicit_If_Statement (N,
-                  Condition =>
-                    Make_Op_Ne (Loc,
-                      Left_Opnd  => New_Reference_To (S, Loc),
-                      Right_Opnd => Make_Null (Loc)),
-
-                   Then_Statements => New_List (
-
-                     --  typ'Read (S, Var);
-
-                     Atr,
-
-                     --  Shared_Var_Close (S);
-
-                     Make_Procedure_Call_Statement (Loc,
-                       Name =>
-                         New_Occurrence_Of
-                           (RTE (RE_Shared_Var_Close), Loc),
-                       Parameter_Associations =>
-                         New_List (New_Reference_To (S, Loc)))))))));
-
-      Set_Is_Shared_Passive      (Ent, True);
-      Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
-      Set_Shared_Var_Read_Proc   (Ent, Read_Proc);
+      --  Construct generic package instantiation
+
+      --  package varG is new Shared_Var_Procs (Typ, var, "pkg.var");
+
+      Instantiation :=
+        Make_Package_Instantiation (Loc,
+          Defining_Unit_Name   => SVP_Instance,
+          Name                 =>
+            New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
+          Generic_Associations => New_List (
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              New_Occurrence_Of (Typ, Loc)),
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              New_Occurrence_Of (Ent, Loc)),
+            Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
+              Make_String_Literal (Loc, Vnm))));
+
+      Insert_After_And_Analyze (N, Instantiation);
+
+      Set_Is_Shared_Passive (Ent, True);
+      Set_Shared_Var_Procs_Instance
+        (Ent, Defining_Entity (Instance_Spec (Instantiation)));
 
       --  Return last node before After
 
diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads
index 69b4ee9..d173825 100644
--- a/gcc/ada/exp_smem.ads
+++ b/gcc/ada/exp_smem.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2008, 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- --
@@ -49,10 +49,11 @@ package Exp_Smem is
    --  read/write calls for the protected object within the lock region.
 
    function Make_Shared_Var_Procs (N : Node_Id) return Node_Id;
-   --  N is the node for the declaration of a shared passive variable. This
-   --  procedure constructs and inserts the read and assignment procedures
-   --  for the shared memory variable. See System.Shared_Storage for a full
-   --  description of these procedures and how they are used. The last inserted
-   --  node is returned.
+   --  N is the node for the declaration of a shared passive variable.
+   --  This procedure constructs an instantiation of
+   --  System.Shared_Storage.Shared_Var_Procs that contains the read and
+   --  assignment procedures for the shared memory variable.
+   --  See System.Shared_Storage for a full description of these procedures
+   --  and how they are used. The last inserted node is returned.
 
 end Exp_Smem;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index ef61b8f..83f7454 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -83,7 +83,7 @@ package Rtsfind is
 
    --    Names of the form System_Tasking_xxx are second level children of the
    --    package System.Tasking. For example, System_Tasking_Stages refers to
-   --    refers to the package System.Tasking.Stages.
+   --    the package System.Tasking.Stages.
 
    --    Other names stand for themselves (e.g. System for package System)
 
@@ -1255,6 +1255,7 @@ package Rtsfind is
      RE_Shared_Var_ROpen,                -- System.Shared_Storage
      RE_Shared_Var_Unlock,               -- System.Shared_Storage
      RE_Shared_Var_WOpen,                -- System.Shared_Storage
+     RE_Shared_Var_Procs,                -- System.Shared_Storage
 
      RE_Abort_Undefer_Direct,            -- System.Standard_Library
      RE_Exception_Code,                  -- System.Standard_Library
@@ -2382,6 +2383,7 @@ package Rtsfind is
      RE_Shared_Var_ROpen                 => System_Shared_Storage,
      RE_Shared_Var_Unlock                => System_Shared_Storage,
      RE_Shared_Var_WOpen                 => System_Shared_Storage,
+     RE_Shared_Var_Procs                 => System_Shared_Storage,
 
      RE_Abort_Undefer_Direct             => System_Standard_Library,
      RE_Exception_Code                   => System_Standard_Library,
diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb
index 5dd7757..c4ef862 100644
--- a/gcc/ada/s-shasto.adb
+++ b/gcc/ada/s-shasto.adb
@@ -6,8 +6,8 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2007, Free Software Foundation, Inc.         --
---                                                                          --
+--          Copyright (C) 1998-2008, 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- --
 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
@@ -364,6 +364,43 @@ package body System.Shared_Storage is
    end Shared_Var_Lock;
 
    ----------------------
+   -- Shared_Var_Procs --
+   ----------------------
+
+   package body Shared_Var_Procs is
+
+      use type SIO.Stream_Access;
+
+      ----------
+      -- Read --
+      ----------
+
+      procedure Read is
+         S : SIO.Stream_Access := null;
+      begin
+         S := Shared_Var_ROpen (Full_Name);
+         if S /= null then
+            Typ'Read (S, V);
+            Shared_Var_Close (S);
+         end if;
+      end Read;
+
+      ------------
+      -- Write --
+      ------------
+
+      procedure Write is
+         S : SIO.Stream_Access := null;
+      begin
+         S := Shared_Var_WOpen (Full_Name);
+         Typ'Write (S, V);
+         Shared_Var_Close (S);
+         return;
+      end Write;
+
+   end Shared_Var_Procs;
+
+   ----------------------
    -- Shared_Var_ROpen --
    ----------------------
 
diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads
index fc4055b..8046fd5 100644
--- a/gcc/ada/s-shasto.ads
+++ b/gcc/ada/s-shasto.ads
@@ -79,48 +79,18 @@
 
 --  The approach is as follows:
 
---    For each shared variable, var, an access routine varR is created whose
---    body has the following form (this example is for Pkg.Var):
-
---      procedure varR is
---         S : Ada.Streams.Stream_IO.Stream_Access;
---      begin
---         S := Shared_Var_ROpen ("pkg.var");
---         if S /= null then
---            typ'Read (S);
---            Shared_Var_Close (S);
---         end if;
---      end varR;
+--    For each shared variable, var, an instanciation of the below generic
+--    package is created which provides Read and Write supporting procedures.
 
 --    The routine Shared_Var_ROpen in package System.Shared_Storage
 --    either returns null if the storage does not exist, or otherwise a
 --    Stream_Access value that references the corresponding shared
 --    storage, ready to read the current value.
 
---    Each reference to the shared variable, var, is preceded by a
---    call to the corresponding varR procedure, which either leaves the
---    initial value unchanged if the storage does not exist, or reads
---    the current value from the shared storage.
-
---    In addition, for each shared variable, var, an assignment routine
---    is created whose body has the following form (again for Pkg.Var)
-
---      procedure VarA is
---         S : Ada.Streams.Stream_IO.Stream_Access;
---      begin
---         S := Shared_Var_WOpen ("pkg.var");
---         typ'Write (S, var);
---         Shared_Var_Close (S);
---      end VarA;
-
 --    The routine Shared_Var_WOpen in package System.Shared_Storage
 --    returns a Stream_Access value that references the corresponding
 --    shared storage, ready to write the new value.
 
---    Each assignment to the shared variable, var, is followed by a call
---    to the corresponding varA procedure, which writes the new value to
---    the shared storage.
-
 --    Note that there is no general synchronization for these storage
 --    read and write operations, since it is assumed that a correctly
 --    operating programs will provide appropriate synchronization. In
@@ -219,4 +189,35 @@ package System.Shared_Storage is
    --  generated as the last operation in the body of a protected
    --  subprogram.
 
+   --  This generic package is instantiated for each shared passive
+   --  variable. It provides supporting procedures called upon each
+   --  read or write access by the expanded code.
+
+   generic
+
+      type Typ is limited private;
+      --  Shared passive variable type
+
+      V : in out Typ;
+      --  Shared passive variable
+
+      Full_Name : String;
+      --  Shared passive variable storage name
+
+   package Shared_Var_Procs is
+
+      procedure Read;
+      --  Shared passive variable access routine. Each reference to the
+      --  shared variable, V, is preceded by a call to the corresponding
+      --  Read procedure, which either leaves the initial value unchanged
+      --  if the storage does not exist, or reads the current value from
+      --  the shared storage.
+
+      procedure Write;
+      --  Shared passive variable assignement routine. Each assignment to
+      --  the shared variable, V, is followed by a call to the corresponding
+      --  Write procedure, which writes the new value to the shared storage.
+
+   end Shared_Var_Procs;
+
 end System.Shared_Storage;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 6a7846e..c2536df 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1278,7 +1278,8 @@ package body Sem_Attr is
            and then Convention (Etype (P)) = Convention_CPP
            and then Is_CPP_Class (Root_Type (Etype (P)))
          then
-            Error_Attr_P ("invalid use of % attribute with CPP tagged type");
+            Error_Attr_P
+              ("invalid use of % attribute with 'C'P'P tagged type");
          end if;
       end Check_Not_CPP_Type;
 
@@ -1459,6 +1460,14 @@ package body Sem_Attr is
          Etyp : Entity_Id;
          Btyp : Entity_Id;
 
+         In_Shared_Var_Procs : Boolean;
+         --  True when compiling the body of System.Shared_Storage.
+         --  Shared_Var_Procs. For this runtime package (always compiled in
+         --  GNAT mode), we allow stream attributes references for limited
+         --  types for the case where shared passive objects are implemented
+         --  using stream attributes, which is the default in GNAT's persistent
+         --  storage implementation.
+
       begin
          Validate_Non_Static_Attribute_Function_Call;
 
@@ -1492,7 +1501,19 @@ package body Sem_Attr is
          --  in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
          --  (with no visibility restriction).
 
-         if Comes_From_Source (N)
+         declare
+            Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
+         begin
+            if Present (Gen_Body) then
+               In_Shared_Var_Procs :=
+                 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
+            else
+               In_Shared_Var_Procs := False;
+            end if;
+         end;
+
+         if (Comes_From_Source (N)
+              and then not (In_Shared_Var_Procs or In_Instance))
            and then not Stream_Attribute_Available (P_Type, Nam)
            and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
          then