1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Exp_Util; use Exp_Util;
30 with Nmake; use Nmake;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Rtsfind; use Rtsfind;
35 with Sem_Util; use Sem_Util;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
40 with Tbuild; use Tbuild;
42 package body Exp_Smem is
44 Insert_Node : Node_Id;
45 -- Node after which a write call is to be inserted
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 procedure Add_Read_Before (N : Node_Id);
52 -- Insert a Shared_Var_ROpen call for variable before node N
54 procedure Add_Write_After (N : Node_Id);
55 -- Insert a Shared_Var_WOpen call for variable after the node
56 -- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points
57 -- to the assignment statement) or Is_Out_Actual (where it points to
58 -- the procedure call statement).
60 procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
61 -- Build the fully qualified string name of a shared variable
63 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
64 -- Determines if N is on the left hand of the assignment. This means
65 -- that either it is a simple variable, or it is a record or array
66 -- variable with a corresponding selected or indexed component on
67 -- the left side of an assignment. If the result is True, then
68 -- Insert_Node is set to point to the assignment
70 function Is_Out_Actual (N : Node_Id) return Boolean;
71 -- In a similar manner, this function determines if N appears as an
72 -- OUT or IN OUT parameter to a procedure call. If the result is
73 -- True, then Insert_Node is set to point to the assignment.
79 procedure Add_Read_Before (N : Node_Id) is
80 Loc : constant Source_Ptr := Sloc (N);
81 Ent : constant Node_Id := Entity (N);
84 if Present (Shared_Var_Read_Proc (Ent)) then
86 Make_Procedure_Call_Statement (Loc,
88 New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
89 Parameter_Associations => Empty_List));
93 -------------------------------
94 -- Add_Shared_Var_Lock_Procs --
95 -------------------------------
97 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
98 Loc : constant Source_Ptr := Sloc (N);
99 Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
104 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
105 -- the procedure or function call node. First we locate the right
106 -- place to do the insertion, which is the call itself in the
107 -- procedure call case, or else the nearest non subexpression
108 -- node that contains the function call.
111 while Nkind (Inode) /= N_Procedure_Call_Statement
112 and then Nkind (Inode) in N_Subexpr
114 Inode := Parent (Inode);
117 -- Now insert the Lock and Unlock calls and the read/write calls
119 -- Two concerns here. First we are not dealing with the exception
120 -- case, really we need some kind of cleanup routine to do the
121 -- Unlock. Second, these lock calls should be inside the protected
122 -- object processing, not outside, otherwise they can be done at
123 -- the wrong priority, resulting in dead lock situations ???
125 Build_Full_Name (Obj, Vnm);
127 -- First insert the Lock call before
129 Insert_Before_And_Analyze (Inode,
130 Make_Procedure_Call_Statement (Loc,
131 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
132 Parameter_Associations => New_List (
133 Make_String_Literal (Loc, Vnm))));
135 -- Now, right after the Lock, insert a call to read the object
137 Insert_Before_And_Analyze (Inode,
138 Make_Procedure_Call_Statement (Loc,
139 Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
141 -- Now insert the Unlock call after
143 Insert_After_And_Analyze (Inode,
144 Make_Procedure_Call_Statement (Loc,
145 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
146 Parameter_Associations => New_List (
147 Make_String_Literal (Loc, Vnm))));
149 -- Now for a procedure call, but not a function call, insert the
150 -- call to write the object just before the unlock.
152 if Nkind (N) = N_Procedure_Call_Statement then
153 Insert_After_And_Analyze (Inode,
154 Make_Procedure_Call_Statement (Loc,
155 Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
158 end Add_Shared_Var_Lock_Procs;
160 ---------------------
161 -- Add_Write_After --
162 ---------------------
164 procedure Add_Write_After (N : Node_Id) is
165 Loc : constant Source_Ptr := Sloc (N);
166 Ent : constant Node_Id := Entity (N);
169 if Present (Shared_Var_Assign_Proc (Ent)) then
170 Insert_After_And_Analyze (Insert_Node,
171 Make_Procedure_Call_Statement (Loc,
173 New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
174 Parameter_Associations => Empty_List));
178 ---------------------
179 -- Build_Full_Name --
180 ---------------------
182 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
184 procedure Build_Name (E : Entity_Id);
185 -- This is a recursive routine used to construct the fully qualified
186 -- string name of the package corresponding to the shared variable.
192 procedure Build_Name (E : Entity_Id) is
194 if Scope (E) /= Standard_Standard then
195 Build_Name (Scope (E));
196 Store_String_Char ('.');
199 Get_Decoded_Name_String (Chars (E));
200 Store_String_Chars (Name_Buffer (1 .. Name_Len));
203 -- Start of processing for Build_Full_Name
211 ------------------------------------
212 -- Expand_Shared_Passive_Variable --
213 ------------------------------------
215 procedure Expand_Shared_Passive_Variable (N : Node_Id) is
216 Typ : constant Entity_Id := Etype (N);
219 -- Nothing to do for protected or limited objects
221 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
224 -- If we are on the left hand side of an assignment, then we add
225 -- the write call after the assignment.
227 elsif On_Lhs_Of_Assignment (N) then
230 -- If we are a parameter for an out or in out formal, then put
231 -- the read before and the write after.
233 elsif Is_Out_Actual (N) then
237 -- All other cases are simple reads
242 end Expand_Shared_Passive_Variable;
248 function Is_Out_Actual (N : Node_Id) return Boolean is
249 Parnt : constant Node_Id := Parent (N);
255 if (Nkind (Parnt) = N_Indexed_Component
257 Nkind (Parnt) = N_Selected_Component)
258 and then N = Prefix (Parnt)
260 return Is_Out_Actual (Parnt);
262 elsif Nkind (Parnt) = N_Parameter_Association
263 and then N = Explicit_Actual_Parameter (Parnt)
265 Call := Parent (Parnt);
267 elsif Nkind (Parnt) = N_Procedure_Call_Statement then
274 -- Fall here if we are definitely a parameter
276 Actual := First_Actual (Call);
277 Formal := First_Formal (Entity (Name (Call)));
281 if Ekind (Formal) /= E_In_Parameter then
289 Actual := Next_Actual (Actual);
290 Formal := Next_Formal (Formal);
295 ---------------------------
296 -- Make_Shared_Var_Procs --
297 ---------------------------
299 procedure Make_Shared_Var_Procs (N : Node_Id) is
300 Loc : constant Source_Ptr := Sloc (N);
301 Ent : constant Entity_Id := Defining_Identifier (N);
302 Typ : constant Entity_Id := Etype (Ent);
306 Assign_Proc : constant Entity_Id :=
307 Make_Defining_Identifier (Loc,
308 Chars => New_External_Name (Chars (Ent), 'A'));
310 Read_Proc : constant Entity_Id :=
311 Make_Defining_Identifier (Loc,
312 Chars => New_External_Name (Chars (Ent), 'R'));
316 -- Start of processing for Make_Shared_Var_Procs
319 Build_Full_Name (Ent, Vnm);
321 -- We turn off Shared_Passive during construction and analysis of
322 -- the assign and read routines, to avoid improper attempts to
323 -- process the variable references within these procedures.
325 Set_Is_Shared_Passive (Ent, False);
327 -- Construct assignment routine
330 -- S : Ada.Streams.Stream_IO.Stream_Access;
332 -- S := Shared_Var_WOpen ("pkg.var");
333 -- typ'Write (S, var);
334 -- Shared_Var_Close (S);
337 S := Make_Defining_Identifier (Loc, Name_uS);
340 Make_Attribute_Reference (Loc,
341 Prefix => New_Occurrence_Of (Typ, Loc),
342 Attribute_Name => Name_Write,
343 Expressions => New_List (
344 New_Reference_To (S, Loc),
345 New_Occurrence_Of (Ent, Loc)));
347 Insert_After_And_Analyze (N,
348 Make_Subprogram_Body (Loc,
350 Make_Procedure_Specification (Loc,
351 Defining_Unit_Name => Assign_Proc),
353 -- S : Ada.Streams.Stream_IO.Stream_Access;
355 Declarations => New_List (
356 Make_Object_Declaration (Loc,
357 Defining_Identifier => S,
359 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
361 Handled_Statement_Sequence =>
362 Make_Handled_Sequence_Of_Statements (Loc,
363 Statements => New_List (
365 -- S := Shared_Var_WOpen ("pkg.var");
367 Make_Assignment_Statement (Loc,
368 Name => New_Reference_To (S, Loc),
370 Make_Function_Call (Loc,
373 (RTE (RE_Shared_Var_WOpen), Loc),
374 Parameter_Associations => New_List (
375 Make_String_Literal (Loc, Vnm)))),
379 -- Shared_Var_Close (S);
381 Make_Procedure_Call_Statement (Loc,
383 New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
384 Parameter_Associations =>
385 New_List (New_Reference_To (S, Loc)))))));
387 -- Construct read routine
390 -- S : Ada.Streams.Stream_IO.Stream_Access;
392 -- S := Shared_Var_ROpen ("pkg.var");
394 -- typ'Read (S, Var);
395 -- Shared_Var_Close (S);
399 S := Make_Defining_Identifier (Loc, Name_uS);
402 Make_Attribute_Reference (Loc,
403 Prefix => New_Occurrence_Of (Typ, Loc),
404 Attribute_Name => Name_Read,
405 Expressions => New_List (
406 New_Reference_To (S, Loc),
407 New_Occurrence_Of (Ent, Loc)));
409 Insert_After_And_Analyze (N,
410 Make_Subprogram_Body (Loc,
412 Make_Procedure_Specification (Loc,
413 Defining_Unit_Name => Read_Proc),
415 -- S : Ada.Streams.Stream_IO.Stream_Access;
417 Declarations => New_List (
418 Make_Object_Declaration (Loc,
419 Defining_Identifier => S,
421 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
423 Handled_Statement_Sequence =>
424 Make_Handled_Sequence_Of_Statements (Loc,
425 Statements => New_List (
427 -- S := Shared_Var_ROpen ("pkg.var");
429 Make_Assignment_Statement (Loc,
430 Name => New_Reference_To (S, Loc),
432 Make_Function_Call (Loc,
435 (RTE (RE_Shared_Var_ROpen), Loc),
436 Parameter_Associations => New_List (
437 Make_String_Literal (Loc, Vnm)))),
441 Make_Implicit_If_Statement (N,
444 Left_Opnd => New_Reference_To (S, Loc),
445 Right_Opnd => Make_Null (Loc)),
447 Then_Statements => New_List (
449 -- typ'Read (S, Var);
453 -- Shared_Var_Close (S);
455 Make_Procedure_Call_Statement (Loc,
458 (RTE (RE_Shared_Var_Close), Loc),
459 Parameter_Associations =>
460 New_List (New_Reference_To (S, Loc)))))))));
462 Set_Is_Shared_Passive (Ent, True);
463 Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
464 Set_Shared_Var_Read_Proc (Ent, Read_Proc);
465 end Make_Shared_Var_Procs;
467 --------------------------
468 -- On_Lhs_Of_Assignment --
469 --------------------------
471 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
472 P : constant Node_Id := Parent (N);
475 if Nkind (P) = N_Assignment_Statement then
483 elsif (Nkind (P) = N_Indexed_Component
485 Nkind (P) = N_Selected_Component)
486 and then N = Prefix (P)
488 return On_Lhs_Of_Assignment (P);
493 end On_Lhs_Of_Assignment;