1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2000 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
63 -- Build the fully qualified string name of a shared variable.
65 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
66 -- Determines if N is on the left hand of the assignment. This means
67 -- that either it is a simple variable, or it is a record or array
68 -- variable with a corresponding selected or indexed component on
69 -- the left side of an assignment. If the result is True, then
70 -- Insert_Node is set to point to the assignment
72 function Is_Out_Actual (N : Node_Id) return Boolean;
73 -- In a similar manner, this function determines if N appears as an
74 -- OUT or IN OUT parameter to a procedure call. If the result is
75 -- True, then Insert_Node is set to point to the assignment.
81 procedure Add_Read_Before (N : Node_Id) is
82 Loc : constant Source_Ptr := Sloc (N);
83 Ent : constant Node_Id := Entity (N);
86 if Present (Shared_Var_Read_Proc (Ent)) then
88 Make_Procedure_Call_Statement (Loc,
90 New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
91 Parameter_Associations => Empty_List));
95 -------------------------------
96 -- Add_Shared_Var_Lock_Procs --
97 -------------------------------
99 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
100 Loc : constant Source_Ptr := Sloc (N);
101 Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
106 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
107 -- the procedure or function call node. First we locate the right
108 -- place to do the insertion, which is the call itself in the
109 -- procedure call case, or else the nearest non subexpression
110 -- node that contains the function call.
113 while Nkind (Inode) /= N_Procedure_Call_Statement
114 and then Nkind (Inode) in N_Subexpr
116 Inode := Parent (Inode);
119 -- Now insert the Lock and Unlock calls and the read/write calls
121 -- Two concerns here. First we are not dealing with the exception
122 -- case, really we need some kind of cleanup routine to do the
123 -- Unlock. Second, these lock calls should be inside the protected
124 -- object processing, not outside, otherwise they can be done at
125 -- the wrong priority, resulting in dead lock situations ???
127 Build_Full_Name (Obj, Vnm);
129 -- First insert the Lock call before
131 Insert_Before_And_Analyze (Inode,
132 Make_Procedure_Call_Statement (Loc,
133 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
134 Parameter_Associations => New_List (
135 Make_String_Literal (Loc, Vnm))));
137 -- Now, right after the Lock, insert a call to read the object
139 Insert_Before_And_Analyze (Inode,
140 Make_Procedure_Call_Statement (Loc,
141 Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
143 -- Now insert the Unlock call after
145 Insert_After_And_Analyze (Inode,
146 Make_Procedure_Call_Statement (Loc,
147 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
148 Parameter_Associations => New_List (
149 Make_String_Literal (Loc, Vnm))));
151 -- Now for a procedure call, but not a function call, insert the
152 -- call to write the object just before the unlock.
154 if Nkind (N) = N_Procedure_Call_Statement then
155 Insert_After_And_Analyze (Inode,
156 Make_Procedure_Call_Statement (Loc,
157 Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
160 end Add_Shared_Var_Lock_Procs;
162 ---------------------
163 -- Add_Write_After --
164 ---------------------
166 procedure Add_Write_After (N : Node_Id) is
167 Loc : constant Source_Ptr := Sloc (N);
168 Ent : constant Node_Id := Entity (N);
171 if Present (Shared_Var_Assign_Proc (Ent)) then
172 Insert_After_And_Analyze (Insert_Node,
173 Make_Procedure_Call_Statement (Loc,
175 New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
176 Parameter_Associations => Empty_List));
180 ---------------------
181 -- Build_Full_Name --
182 ---------------------
184 procedure Build_Full_Name
189 procedure Build_Name (E : Entity_Id);
190 -- This is a recursive routine used to construct the fully
191 -- qualified string name of the package corresponding to the
194 procedure Build_Name (E : Entity_Id) is
196 if Scope (E) /= Standard_Standard then
197 Build_Name (Scope (E));
198 Store_String_Char ('.');
201 Get_Decoded_Name_String (Chars (E));
202 Store_String_Chars (Name_Buffer (1 .. Name_Len));
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 Set_OK_For_Stream (Atr, True);
349 Insert_After_And_Analyze (N,
350 Make_Subprogram_Body (Loc,
352 Make_Procedure_Specification (Loc,
353 Defining_Unit_Name => Assign_Proc),
355 -- S : Ada.Streams.Stream_IO.Stream_Access;
357 Declarations => New_List (
358 Make_Object_Declaration (Loc,
359 Defining_Identifier => S,
361 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
363 Handled_Statement_Sequence =>
364 Make_Handled_Sequence_Of_Statements (Loc,
365 Statements => New_List (
367 -- S := Shared_Var_WOpen ("pkg.var");
369 Make_Assignment_Statement (Loc,
370 Name => New_Reference_To (S, Loc),
372 Make_Function_Call (Loc,
375 (RTE (RE_Shared_Var_WOpen), Loc),
376 Parameter_Associations => New_List (
377 Make_String_Literal (Loc, Vnm)))),
381 -- Shared_Var_Close (S);
383 Make_Procedure_Call_Statement (Loc,
385 New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
386 Parameter_Associations =>
387 New_List (New_Reference_To (S, Loc)))))));
389 -- Construct read routine
392 -- S : Ada.Streams.Stream_IO.Stream_Access;
394 -- S := Shared_Var_ROpen ("pkg.var");
396 -- typ'Read (S, Var);
397 -- Shared_Var_Close (S);
401 S := Make_Defining_Identifier (Loc, Name_uS);
404 Make_Attribute_Reference (Loc,
405 Prefix => New_Occurrence_Of (Typ, Loc),
406 Attribute_Name => Name_Read,
407 Expressions => New_List (
408 New_Reference_To (S, Loc),
409 New_Occurrence_Of (Ent, Loc)));
411 Set_OK_For_Stream (Atr, True);
413 Insert_After_And_Analyze (N,
414 Make_Subprogram_Body (Loc,
416 Make_Procedure_Specification (Loc,
417 Defining_Unit_Name => Read_Proc),
419 -- S : Ada.Streams.Stream_IO.Stream_Access;
421 Declarations => New_List (
422 Make_Object_Declaration (Loc,
423 Defining_Identifier => S,
425 New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
427 Handled_Statement_Sequence =>
428 Make_Handled_Sequence_Of_Statements (Loc,
429 Statements => New_List (
431 -- S := Shared_Var_ROpen ("pkg.var");
433 Make_Assignment_Statement (Loc,
434 Name => New_Reference_To (S, Loc),
436 Make_Function_Call (Loc,
439 (RTE (RE_Shared_Var_ROpen), Loc),
440 Parameter_Associations => New_List (
441 Make_String_Literal (Loc, Vnm)))),
445 Make_Implicit_If_Statement (N,
448 Left_Opnd => New_Reference_To (S, Loc),
449 Right_Opnd => Make_Null (Loc)),
451 Then_Statements => New_List (
453 -- typ'Read (S, Var);
457 -- Shared_Var_Close (S);
459 Make_Procedure_Call_Statement (Loc,
462 (RTE (RE_Shared_Var_Close), Loc),
463 Parameter_Associations =>
464 New_List (New_Reference_To (S, Loc)))))))));
466 Set_Is_Shared_Passive (Ent, True);
467 Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
468 Set_Shared_Var_Read_Proc (Ent, Read_Proc);
469 end Make_Shared_Var_Procs;
471 --------------------------
472 -- On_Lhs_Of_Assignment --
473 --------------------------
475 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
476 P : constant Node_Id := Parent (N);
479 if Nkind (P) = N_Assignment_Statement then
487 elsif (Nkind (P) = N_Indexed_Component
489 Nkind (P) = N_Selected_Component)
490 and then N = Prefix (P)
492 return On_Lhs_Of_Assignment (P);
497 end On_Lhs_Of_Assignment;