New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45954 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 502 insertions, 0 deletions

diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb
new file mode 100644
index 00000000000..b89f42fc405
--- /dev/null
+++ b/gcc/ada/exp_smem.adb
@@ -0,0 +1,502 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ S M E M                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--          Copyright (C) 1998-2000 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- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Exp_Util; use Exp_Util;
+with Nmake;    use Nmake;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Rtsfind;  use Rtsfind;
+with Sem;      use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Tbuild;   use Tbuild;
+
+package body Exp_Smem is
+
+   Insert_Node : Node_Id;
+   --  Node after which a write call is to be inserted
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Add_Read_Before (N : Node_Id);
+   --  Insert a Shared_Var_ROpen call for variable before node N
+
+   procedure Add_Write_After (N : Node_Id);
+   --  Insert a Shared_Var_WOpen call for variable after the node
+   --  Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points
+   --  to the assignment statement) or Is_Out_Actual (where it points to
+   --  the procedure call statement).
+
+   procedure Build_Full_Name
+     (E : in  Entity_Id;
+      N : out String_Id);
+   --  Build the fully qualified string name of a shared variable.
+
+   function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
+   --  Determines if N is on the left hand of the assignment. This means
+   --  that either it is a simple variable, or it is a record or array
+   --  variable with a corresponding selected or indexed component on
+   --  the left side of an assignment. If the result is True, then
+   --  Insert_Node is set to point to the assignment
+
+   function Is_Out_Actual (N : Node_Id) return Boolean;
+   --  In a similar manner, this function determines if N appears as an
+   --  OUT or IN OUT parameter to a procedure call. If the result is
+   --  True, then Insert_Node is set to point to the assignment.
+
+   ---------------------
+   -- Add_Read_Before --
+   ---------------------
+
+   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));
+      end if;
+   end Add_Read_Before;
+
+   -------------------------------
+   -- Add_Shared_Var_Lock_Procs --
+   -------------------------------
+
+   procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
+      Loc   : constant Source_Ptr := Sloc (N);
+      Obj   : constant Entity_Id  := Entity (Expression (First_Actual (N)));
+      Inode : Node_Id;
+      Vnm   : String_Id;
+
+   begin
+      --  We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
+      --  the procedure or function call node. First we locate the right
+      --  place to do the insertion, which is the call itself in the
+      --  procedure call case, or else the nearest non subexpression
+      --  node that contains the function call.
+
+      Inode := N;
+      while Nkind (Inode) /= N_Procedure_Call_Statement
+        and then Nkind (Inode) in N_Subexpr
+      loop
+         Inode := Parent (Inode);
+      end loop;
+
+      --  Now insert the Lock and Unlock calls and the read/write calls
+
+      --  Two concerns here. First we are not dealing with the exception
+      --  case, really we need some kind of cleanup routine to do the
+      --  Unlock. Second, these lock calls should be inside the protected
+      --  object processing, not outside, otherwise they can be done at
+      --  the wrong priority, resulting in dead lock situations ???
+
+      Build_Full_Name (Obj, Vnm);
+
+      --  First insert the Lock call before
+
+      Insert_Before_And_Analyze (Inode,
+        Make_Procedure_Call_Statement (Loc,
+          Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
+          Parameter_Associations => New_List (
+            Make_String_Literal (Loc, Vnm))));
+
+      --  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)));
+
+      --  Now insert the Unlock call after
+
+      Insert_After_And_Analyze (Inode,
+        Make_Procedure_Call_Statement (Loc,
+          Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
+          Parameter_Associations => New_List (
+            Make_String_Literal (Loc, Vnm))));
+
+      --  Now for a procedure call, but not a function call, insert the
+      --  call to write the object just before the unlock.
+
+      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)));
+      end if;
+
+   end Add_Shared_Var_Lock_Procs;
+
+   ---------------------
+   -- Add_Write_After --
+   ---------------------
+
+   procedure Add_Write_After (N : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Ent : constant Node_Id    := Entity (N);
+
+   begin
+      if Present (Shared_Var_Assign_Proc (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));
+      end if;
+   end Add_Write_After;
+
+   ---------------------
+   -- Build_Full_Name --
+   ---------------------
+
+   procedure Build_Full_Name
+     (E : in  Entity_Id;
+      N : out String_Id)
+   is
+
+      procedure Build_Name (E : Entity_Id);
+      --  This is a recursive routine used to construct the fully
+      --  qualified string name of the package corresponding to the
+      --  shared variable.
+
+      procedure Build_Name (E : Entity_Id) is
+      begin
+         if Scope (E) /= Standard_Standard then
+            Build_Name (Scope (E));
+            Store_String_Char ('.');
+         end if;
+
+         Get_Decoded_Name_String (Chars (E));
+         Store_String_Chars (Name_Buffer (1 .. Name_Len));
+      end Build_Name;
+
+   begin
+      Start_String;
+      Build_Name (E);
+      N := End_String;
+   end Build_Full_Name;
+
+   ------------------------------------
+   -- Expand_Shared_Passive_Variable --
+   ------------------------------------
+
+   procedure Expand_Shared_Passive_Variable (N : Node_Id) is
+      Typ : constant Entity_Id := Etype (N);
+
+   begin
+      --  Nothing to do for protected or limited objects
+
+      if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
+         return;
+
+      --  If we are on the left hand side of an assignment, then we add
+      --  the write call after the assignment.
+
+      elsif On_Lhs_Of_Assignment (N) then
+         Add_Write_After (N);
+
+      --  If we are a parameter for an out or in out formal, then put
+      --  the read before and the write after.
+
+      elsif Is_Out_Actual (N) then
+         Add_Read_Before (N);
+         Add_Write_After (N);
+
+      --  All other cases are simple reads
+
+      else
+         Add_Read_Before (N);
+      end if;
+   end Expand_Shared_Passive_Variable;
+
+   -------------------
+   -- Is_Out_Actual --
+   -------------------
+
+   function Is_Out_Actual (N : Node_Id) return Boolean is
+      Parnt  : constant Node_Id := Parent (N);
+      Formal : Entity_Id;
+      Call   : Node_Id;
+      Actual : Node_Id;
+
+   begin
+      if (Nkind (Parnt) = N_Indexed_Component
+            or else
+          Nkind (Parnt) = N_Selected_Component)
+        and then N = Prefix (Parnt)
+      then
+         return Is_Out_Actual (Parnt);
+
+      elsif Nkind (Parnt) = N_Parameter_Association
+        and then N = Explicit_Actual_Parameter (Parnt)
+      then
+         Call := Parent (Parnt);
+
+      elsif Nkind (Parnt) = N_Procedure_Call_Statement then
+         Call := Parnt;
+
+      else
+         return False;
+      end if;
+
+      --  Fall here if we are definitely a parameter
+
+      Actual := First_Actual (Call);
+      Formal := First_Formal (Entity (Name (Call)));
+
+      loop
+         if Actual = N then
+            if Ekind (Formal) /= E_In_Parameter then
+               Insert_Node := Call;
+               return True;
+            else
+               return False;
+            end if;
+
+         else
+            Actual := Next_Actual (Actual);
+            Formal := Next_Formal (Formal);
+         end if;
+      end loop;
+   end Is_Out_Actual;
+
+   ---------------------------
+   -- Make_Shared_Var_Procs --
+   ---------------------------
+
+   procedure Make_Shared_Var_Procs (N : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Ent : constant Entity_Id  := Defining_Identifier (N);
+      Typ : constant Entity_Id  := Etype (Ent);
+      Vnm : String_Id;
+      Atr : Node_Id;
+
+      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'));
+
+      S : Entity_Id;
+
+   --  Start of processing for Make_Shared_Var_Procs
+
+   begin
+      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.
+
+      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)));
+
+      Set_OK_For_Stream (Atr, True);
+
+      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)));
+
+      Set_OK_For_Stream (Atr, True);
+
+      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);
+   end Make_Shared_Var_Procs;
+
+   --------------------------
+   -- On_Lhs_Of_Assignment --
+   --------------------------
+
+   function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
+      P : constant Node_Id := Parent (N);
+
+   begin
+      if Nkind (P) = N_Assignment_Statement then
+         if N = Name (P) then
+            Insert_Node := P;
+            return True;
+         else
+            return False;
+         end if;
+
+      elsif (Nkind (P) = N_Indexed_Component
+               or else
+             Nkind (P) = N_Selected_Component)
+        and then N = Prefix (P)
+      then
+         return On_Lhs_Of_Assignment (P);
+
+      else
+         return False;
+      end if;
+   end On_Lhs_Of_Assignment;
+
+
+end Exp_Smem;