1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Exp_Util; use Exp_Util;
29 with Nmake; use Nmake;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Rtsfind; use Rtsfind;
34 with Sem_Util; use Sem_Util;
35 with Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Stringt; use Stringt;
39 with Tbuild; use Tbuild;
41 package body Exp_Smem is
43 Insert_Node : Node_Id;
44 -- Node after which a write call is to be inserted
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
50 procedure Add_Read_Before (N : Node_Id);
51 -- Insert a Shared_Var_ROpen call for variable before node N
53 procedure Add_Write_After (N : Node_Id);
54 -- Insert a Shared_Var_WOpen call for variable after the node
55 -- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points
56 -- to the assignment statement) or Is_Out_Actual (where it points to
57 -- the procedure call statement).
59 procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
60 -- Build the fully qualified string name of a shared variable
62 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
63 -- Determines if N is on the left hand of the assignment. This means
64 -- that either it is a simple variable, or it is a record or array
65 -- variable with a corresponding selected or indexed component on
66 -- the left side of an assignment. If the result is True, then
67 -- Insert_Node is set to point to the assignment
69 function Is_Out_Actual (N : Node_Id) return Boolean;
70 -- In a similar manner, this function determines if N appears as an
71 -- OUT or IN OUT parameter to a procedure call. If the result is
72 -- True, then Insert_Node is set to point to the assignment.
78 procedure Add_Read_Before (N : Node_Id) is
79 Loc : constant Source_Ptr := Sloc (N);
80 Ent : constant Node_Id := Entity (N);
83 if Present (Shared_Var_Read_Proc (Ent)) then
85 Make_Procedure_Call_Statement (Loc,
87 New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
88 Parameter_Associations => Empty_List));
92 -------------------------------
93 -- Add_Shared_Var_Lock_Procs --
94 -------------------------------
96 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
97 Loc : constant Source_Ptr := Sloc (N);
98 Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
103 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
104 -- the procedure or function call node. First we locate the right
105 -- place to do the insertion, which is the call itself in the
106 -- procedure call case, or else the nearest non subexpression
107 -- node that contains the function call.
110 while Nkind (Inode) /= N_Procedure_Call_Statement
111 and then Nkind (Inode) in N_Subexpr
113 Inode := Parent (Inode);
116 -- Now insert the Lock and Unlock calls and the read/write calls
118 -- Two concerns here. First we are not dealing with the exception
119 -- case, really we need some kind of cleanup routine to do the
120 -- Unlock. Second, these lock calls should be inside the protected
121 -- object processing, not outside, otherwise they can be done at
122 -- the wrong priority, resulting in dead lock situations ???
124 Build_Full_Name (Obj, Vnm);
126 -- First insert the Lock call before
128 Insert_Before_And_Analyze (Inode,
129 Make_Procedure_Call_Statement (Loc,
130 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
131 Parameter_Associations => New_List (
132 Make_String_Literal (Loc, Vnm))));
134 -- Now, right after the Lock, insert a call to read the object
136 Insert_Before_And_Analyze (Inode,
137 Make_Procedure_Call_Statement (Loc,
138 Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
140 -- Now insert the Unlock call after
142 Insert_After_And_Analyze (Inode,
143 Make_Procedure_Call_Statement (Loc,
144 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
145 Parameter_Associations => New_List (
146 Make_String_Literal (Loc, Vnm))));
148 -- Now for a procedure call, but not a function call, insert the
149 -- call to write the object just before the unlock.
151 if Nkind (N) = N_Procedure_Call_Statement then
152 Insert_After_And_Analyze (Inode,
153 Make_Procedure_Call_Statement (Loc,
154 Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
157 end Add_Shared_Var_Lock_Procs;
159 ---------------------
160 -- Add_Write_After --
161 ---------------------
163 procedure Add_Write_After (N : Node_Id) is
164 Loc : constant Source_Ptr := Sloc (N);
165 Ent : constant Node_Id := Entity (N);
168 if Present (Shared_Var_Assign_Proc (Ent)) then
169 Insert_After_And_Analyze (Insert_Node,
170 Make_Procedure_Call_Statement (Loc,
172 New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
173 Parameter_Associations => Empty_List));
177 ---------------------
178 -- Build_Full_Name --
179 ---------------------
181 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
183 procedure Build_Name (E : Entity_Id);
184 -- This is a recursive routine used to construct the fully qualified
185 -- string name of the package corresponding to the shared variable.
191 procedure Build_Name (E : Entity_Id) is
193 if Scope (E) /= Standard_Standard then
194 Build_Name (Scope (E));
195 Store_String_Char ('.');
198 Get_Decoded_Name_String (Chars (E));
199 Store_String_Chars (Name_Buffer (1 .. Name_Len));
202 -- Start of processing for Build_Full_Name
210 ------------------------------------
211 -- Expand_Shared_Passive_Variable --
212 ------------------------------------
214 procedure Expand_Shared_Passive_Variable (N : Node_Id) is
215 Typ : constant Entity_Id := Etype (N);
218 -- Nothing to do for protected or limited objects
220 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
223 -- If we are on the left hand side of an assignment, then we add
224 -- the write call after the assignment.
226 elsif On_Lhs_Of_Assignment (N) then
229 -- If we are a parameter for an out or in out formal, then put
230 -- the read before and the write after.
232 elsif Is_Out_Actual (N) then
236 -- All other cases are simple reads
241 end Expand_Shared_Passive_Variable;
247 function Is_Out_Actual (N : Node_Id) return Boolean is
248 Parnt : constant Node_Id := Parent (N);
254 if (Nkind (Parnt) = N_Indexed_Component
256 Nkind (Parnt) = N_Selected_Component)
257 and then N = Prefix (Parnt)
259 return Is_Out_Actual (Parnt);
261 elsif Nkind (Parnt) = N_Parameter_Association
262 and then N = Explicit_Actual_Parameter (Parnt)
264 Call := Parent (Parnt);
266 elsif Nkind (Parnt) = N_Procedure_Call_Statement then
273 -- Fall here if we are definitely a parameter
275 Actual := First_Actual (Call);
276 Formal := First_Formal (Entity (Name (Call)));
280 if Ekind (Formal) /= E_In_Parameter then
288 Actual := Next_Actual (Actual);
289 Formal := Next_Formal (Formal);
294 ---------------------------
295 -- Make_Shared_Var_Procs --
296 ---------------------------
298 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
299 Loc : constant Source_Ptr := Sloc (N);
300 Ent : constant Entity_Id := Defining_Identifier (N);
301 Typ : constant Entity_Id := Etype (Ent);
305 After : constant Node_Id := Next (N);
306 -- Node located right after N originally (after insertion of the SV
307 -- procs this node is right after the last inserted node).
309 Assign_Proc : constant Entity_Id :=
310 Make_Defining_Identifier (Loc,
311 Chars => New_External_Name (Chars (Ent), 'A'));
313 Read_Proc : constant Entity_Id :=
314 Make_Defining_Identifier (Loc,
315 Chars => New_External_Name (Chars (Ent), 'R'));
319 -- Start of processing for Make_Shared_Var_Procs
322 Build_Full_Name (Ent, Vnm);
324 -- We turn off Shared_Passive during construction and analysis of
325 -- the assign and read routines, to avoid improper attempts to
326 -- process the variable references within these procedures.
328 Set_Is_Shared_Passive (Ent, False);
330 -- Construct assignment routine
333 -- S : Ada.Streams.Stream_IO.Stream_Access;
335 -- S := Shared_Var_WOpen ("pkg.var");
336 -- typ'Write (S, var);
337 -- Shared_Var_Close (S);
340 S := Make_Defining_Identifier (Loc, Name_uS);
343 Make_Attribute_Reference (Loc,
344 Prefix => New_Occurrence_Of (Typ, Loc),
345 Attribute_Name => Name_Write,
346 Expressions => New_List (
347 New_Reference_To (S, Loc),
348 New_Occurrence_Of (Ent, Loc)));
350 Insert_After_And_Analyze (N,
351 Make_Subprogram_Body (Loc,
353 Make_Procedure_Specification (Loc,
354 Defining_Unit_Name => Assign_Proc),
356 -- S : Ada.Streams.Stream_IO.Stream_Access;
358 Declarations => New_List (
359 Make_Object_Declaration (Loc,
360 Defining_Identifier => S,
362 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
364 Handled_Statement_Sequence =>
365 Make_Handled_Sequence_Of_Statements (Loc,
366 Statements => New_List (
368 -- S := Shared_Var_WOpen ("pkg.var");
370 Make_Assignment_Statement (Loc,
371 Name => New_Reference_To (S, Loc),
373 Make_Function_Call (Loc,
376 (RTE (RE_Shared_Var_WOpen), Loc),
377 Parameter_Associations => New_List (
378 Make_String_Literal (Loc, Vnm)))),
382 -- Shared_Var_Close (S);
384 Make_Procedure_Call_Statement (Loc,
386 New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
387 Parameter_Associations =>
388 New_List (New_Reference_To (S, Loc)))))));
390 -- Construct read routine
393 -- S : Ada.Streams.Stream_IO.Stream_Access;
395 -- S := Shared_Var_ROpen ("pkg.var");
397 -- typ'Read (S, Var);
398 -- Shared_Var_Close (S);
402 S := Make_Defining_Identifier (Loc, Name_uS);
405 Make_Attribute_Reference (Loc,
406 Prefix => New_Occurrence_Of (Typ, Loc),
407 Attribute_Name => Name_Read,
408 Expressions => New_List (
409 New_Reference_To (S, Loc),
410 New_Occurrence_Of (Ent, Loc)));
412 Insert_After_And_Analyze (N,
413 Make_Subprogram_Body (Loc,
415 Make_Procedure_Specification (Loc,
416 Defining_Unit_Name => Read_Proc),
418 -- S : Ada.Streams.Stream_IO.Stream_Access;
420 Declarations => New_List (
421 Make_Object_Declaration (Loc,
422 Defining_Identifier => S,
424 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
426 Handled_Statement_Sequence =>
427 Make_Handled_Sequence_Of_Statements (Loc,
428 Statements => New_List (
430 -- S := Shared_Var_ROpen ("pkg.var");
432 Make_Assignment_Statement (Loc,
433 Name => New_Reference_To (S, Loc),
435 Make_Function_Call (Loc,
438 (RTE (RE_Shared_Var_ROpen), Loc),
439 Parameter_Associations => New_List (
440 Make_String_Literal (Loc, Vnm)))),
444 Make_Implicit_If_Statement (N,
447 Left_Opnd => New_Reference_To (S, Loc),
448 Right_Opnd => Make_Null (Loc)),
450 Then_Statements => New_List (
452 -- typ'Read (S, Var);
456 -- Shared_Var_Close (S);
458 Make_Procedure_Call_Statement (Loc,
461 (RTE (RE_Shared_Var_Close), Loc),
462 Parameter_Associations =>
463 New_List (New_Reference_To (S, Loc)))))))));
465 Set_Is_Shared_Passive (Ent, True);
466 Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
467 Set_Shared_Var_Read_Proc (Ent, Read_Proc);
469 -- Return last node before After
472 Nod : Node_Id := Next (N);
475 while Next (Nod) /= After loop
481 end Make_Shared_Var_Procs;
483 --------------------------
484 -- On_Lhs_Of_Assignment --
485 --------------------------
487 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
488 P : constant Node_Id := Parent (N);
491 if Nkind (P) = N_Assignment_Statement then
499 elsif (Nkind (P) = N_Indexed_Component
501 Nkind (P) = N_Selected_Component)
502 and then N = Prefix (P)
504 return On_Lhs_Of_Assignment (P);
509 end On_Lhs_Of_Assignment;