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 call.
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
252 Find_Actual_Mode
(N
, Kind
, Call
);
254 if Kind
= E_Out_Parameter
or else Kind
= E_In_Out_Parameter
then
262 ---------------------------
263 -- Make_Shared_Var_Procs --
264 ---------------------------
266 function Make_Shared_Var_Procs
(N
: Node_Id
) return Node_Id
is
267 Loc
: constant Source_Ptr
:= Sloc
(N
);
268 Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
269 Typ
: constant Entity_Id
:= Etype
(Ent
);
273 After
: constant Node_Id
:= Next
(N
);
274 -- Node located right after N originally (after insertion of the SV
275 -- procs this node is right after the last inserted node).
277 Assign_Proc
: constant Entity_Id
:=
278 Make_Defining_Identifier
(Loc
,
279 Chars
=> New_External_Name
(Chars
(Ent
), 'A'));
281 Read_Proc
: constant Entity_Id
:=
282 Make_Defining_Identifier
(Loc
,
283 Chars
=> New_External_Name
(Chars
(Ent
), 'R'));
287 -- Start of processing for Make_Shared_Var_Procs
290 Build_Full_Name
(Ent
, Vnm
);
292 -- We turn off Shared_Passive during construction and analysis of
293 -- the assign and read routines, to avoid improper attempts to
294 -- process the variable references within these procedures.
296 Set_Is_Shared_Passive
(Ent
, False);
298 -- Construct assignment routine
301 -- S : Ada.Streams.Stream_IO.Stream_Access;
303 -- S := Shared_Var_WOpen ("pkg.var");
304 -- typ'Write (S, var);
305 -- Shared_Var_Close (S);
308 S
:= Make_Defining_Identifier
(Loc
, Name_uS
);
311 Make_Attribute_Reference
(Loc
,
312 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
313 Attribute_Name
=> Name_Write
,
314 Expressions
=> New_List
(
315 New_Reference_To
(S
, Loc
),
316 New_Occurrence_Of
(Ent
, Loc
)));
318 Insert_After_And_Analyze
(N
,
319 Make_Subprogram_Body
(Loc
,
321 Make_Procedure_Specification
(Loc
,
322 Defining_Unit_Name
=> Assign_Proc
),
324 -- S : Ada.Streams.Stream_IO.Stream_Access;
326 Declarations
=> New_List
(
327 Make_Object_Declaration
(Loc
,
328 Defining_Identifier
=> S
,
330 New_Occurrence_Of
(RTE
(RE_Stream_Access
), Loc
))),
332 Handled_Statement_Sequence
=>
333 Make_Handled_Sequence_Of_Statements
(Loc
,
334 Statements
=> New_List
(
336 -- S := Shared_Var_WOpen ("pkg.var");
338 Make_Assignment_Statement
(Loc
,
339 Name
=> New_Reference_To
(S
, Loc
),
341 Make_Function_Call
(Loc
,
344 (RTE
(RE_Shared_Var_WOpen
), Loc
),
345 Parameter_Associations
=> New_List
(
346 Make_String_Literal
(Loc
, Vnm
)))),
350 -- Shared_Var_Close (S);
352 Make_Procedure_Call_Statement
(Loc
,
354 New_Occurrence_Of
(RTE
(RE_Shared_Var_Close
), Loc
),
355 Parameter_Associations
=>
356 New_List
(New_Reference_To
(S
, Loc
)))))));
358 -- Construct read routine
361 -- S : Ada.Streams.Stream_IO.Stream_Access;
363 -- S := Shared_Var_ROpen ("pkg.var");
365 -- typ'Read (S, Var);
366 -- Shared_Var_Close (S);
370 S
:= Make_Defining_Identifier
(Loc
, Name_uS
);
373 Make_Attribute_Reference
(Loc
,
374 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
375 Attribute_Name
=> Name_Read
,
376 Expressions
=> New_List
(
377 New_Reference_To
(S
, Loc
),
378 New_Occurrence_Of
(Ent
, Loc
)));
380 Insert_After_And_Analyze
(N
,
381 Make_Subprogram_Body
(Loc
,
383 Make_Procedure_Specification
(Loc
,
384 Defining_Unit_Name
=> Read_Proc
),
386 -- S : Ada.Streams.Stream_IO.Stream_Access;
388 Declarations
=> New_List
(
389 Make_Object_Declaration
(Loc
,
390 Defining_Identifier
=> S
,
392 New_Occurrence_Of
(RTE
(RE_Stream_Access
), Loc
))),
394 Handled_Statement_Sequence
=>
395 Make_Handled_Sequence_Of_Statements
(Loc
,
396 Statements
=> New_List
(
398 -- S := Shared_Var_ROpen ("pkg.var");
400 Make_Assignment_Statement
(Loc
,
401 Name
=> New_Reference_To
(S
, Loc
),
403 Make_Function_Call
(Loc
,
406 (RTE
(RE_Shared_Var_ROpen
), Loc
),
407 Parameter_Associations
=> New_List
(
408 Make_String_Literal
(Loc
, Vnm
)))),
412 Make_Implicit_If_Statement
(N
,
415 Left_Opnd
=> New_Reference_To
(S
, Loc
),
416 Right_Opnd
=> Make_Null
(Loc
)),
418 Then_Statements
=> New_List
(
420 -- typ'Read (S, Var);
424 -- Shared_Var_Close (S);
426 Make_Procedure_Call_Statement
(Loc
,
429 (RTE
(RE_Shared_Var_Close
), Loc
),
430 Parameter_Associations
=>
431 New_List
(New_Reference_To
(S
, Loc
)))))))));
433 Set_Is_Shared_Passive
(Ent
, True);
434 Set_Shared_Var_Assign_Proc
(Ent
, Assign_Proc
);
435 Set_Shared_Var_Read_Proc
(Ent
, Read_Proc
);
437 -- Return last node before After
440 Nod
: Node_Id
:= Next
(N
);
443 while Next
(Nod
) /= After
loop
449 end Make_Shared_Var_Procs
;
451 --------------------------
452 -- On_Lhs_Of_Assignment --
453 --------------------------
455 function On_Lhs_Of_Assignment
(N
: Node_Id
) return Boolean is
456 P
: constant Node_Id
:= Parent
(N
);
459 if Nkind
(P
) = N_Assignment_Statement
then
467 elsif (Nkind
(P
) = N_Indexed_Component
469 Nkind
(P
) = N_Selected_Component
)
470 and then N
= Prefix
(P
)
472 return On_Lhs_Of_Assignment
(P
);
477 end On_Lhs_Of_Assignment
;