+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ S M E M --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff