1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1998-2000 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Einfo
; use Einfo
;
30 with Exp_Util
; use Exp_Util
;
31 with Nmake
; use Nmake
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
34 with Rtsfind
; use Rtsfind
;
36 with Sem_Util
; use Sem_Util
;
37 with Sinfo
; use Sinfo
;
38 with Snames
; use Snames
;
39 with Stand
; use Stand
;
40 with Stringt
; use Stringt
;
41 with Tbuild
; use Tbuild
;
43 package body Exp_Smem
is
45 Insert_Node
: Node_Id
;
46 -- Node after which a write call is to be inserted
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
52 procedure Add_Read_Before
(N
: Node_Id
);
53 -- Insert a Shared_Var_ROpen call for variable before node N
55 procedure Add_Write_After
(N
: Node_Id
);
56 -- Insert a Shared_Var_WOpen call for variable after the node
57 -- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points
58 -- to the assignment statement) or Is_Out_Actual (where it points to
59 -- the procedure call statement).
61 procedure Build_Full_Name
64 -- Build the fully qualified string name of a shared variable.
66 function On_Lhs_Of_Assignment
(N
: Node_Id
) return Boolean;
67 -- Determines if N is on the left hand of the assignment. This means
68 -- that either it is a simple variable, or it is a record or array
69 -- variable with a corresponding selected or indexed component on
70 -- the left side of an assignment. If the result is True, then
71 -- Insert_Node is set to point to the assignment
73 function Is_Out_Actual
(N
: Node_Id
) return Boolean;
74 -- In a similar manner, this function determines if N appears as an
75 -- OUT or IN OUT parameter to a procedure call. If the result is
76 -- True, then Insert_Node is set to point to the assignment.
82 procedure Add_Read_Before
(N
: Node_Id
) is
83 Loc
: constant Source_Ptr
:= Sloc
(N
);
84 Ent
: constant Node_Id
:= Entity
(N
);
87 if Present
(Shared_Var_Read_Proc
(Ent
)) then
89 Make_Procedure_Call_Statement
(Loc
,
91 New_Occurrence_Of
(Shared_Var_Read_Proc
(Ent
), Loc
),
92 Parameter_Associations
=> Empty_List
));
96 -------------------------------
97 -- Add_Shared_Var_Lock_Procs --
98 -------------------------------
100 procedure Add_Shared_Var_Lock_Procs
(N
: Node_Id
) is
101 Loc
: constant Source_Ptr
:= Sloc
(N
);
102 Obj
: constant Entity_Id
:= Entity
(Expression
(First_Actual
(N
)));
107 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
108 -- the procedure or function call node. First we locate the right
109 -- place to do the insertion, which is the call itself in the
110 -- procedure call case, or else the nearest non subexpression
111 -- node that contains the function call.
114 while Nkind
(Inode
) /= N_Procedure_Call_Statement
115 and then Nkind
(Inode
) in N_Subexpr
117 Inode
:= Parent
(Inode
);
120 -- Now insert the Lock and Unlock calls and the read/write calls
122 -- Two concerns here. First we are not dealing with the exception
123 -- case, really we need some kind of cleanup routine to do the
124 -- Unlock. Second, these lock calls should be inside the protected
125 -- object processing, not outside, otherwise they can be done at
126 -- the wrong priority, resulting in dead lock situations ???
128 Build_Full_Name
(Obj
, Vnm
);
130 -- First insert the Lock call before
132 Insert_Before_And_Analyze
(Inode
,
133 Make_Procedure_Call_Statement
(Loc
,
134 Name
=> New_Occurrence_Of
(RTE
(RE_Shared_Var_Lock
), Loc
),
135 Parameter_Associations
=> New_List
(
136 Make_String_Literal
(Loc
, Vnm
))));
138 -- Now, right after the Lock, insert a call to read the object
140 Insert_Before_And_Analyze
(Inode
,
141 Make_Procedure_Call_Statement
(Loc
,
142 Name
=> New_Occurrence_Of
(Shared_Var_Read_Proc
(Obj
), Loc
)));
144 -- Now insert the Unlock call after
146 Insert_After_And_Analyze
(Inode
,
147 Make_Procedure_Call_Statement
(Loc
,
148 Name
=> New_Occurrence_Of
(RTE
(RE_Shared_Var_Unlock
), Loc
),
149 Parameter_Associations
=> New_List
(
150 Make_String_Literal
(Loc
, Vnm
))));
152 -- Now for a procedure call, but not a function call, insert the
153 -- call to write the object just before the unlock.
155 if Nkind
(N
) = N_Procedure_Call_Statement
then
156 Insert_After_And_Analyze
(Inode
,
157 Make_Procedure_Call_Statement
(Loc
,
158 Name
=> New_Occurrence_Of
(Shared_Var_Assign_Proc
(Obj
), Loc
)));
161 end Add_Shared_Var_Lock_Procs
;
163 ---------------------
164 -- Add_Write_After --
165 ---------------------
167 procedure Add_Write_After
(N
: Node_Id
) is
168 Loc
: constant Source_Ptr
:= Sloc
(N
);
169 Ent
: constant Node_Id
:= Entity
(N
);
172 if Present
(Shared_Var_Assign_Proc
(Ent
)) then
173 Insert_After_And_Analyze
(Insert_Node
,
174 Make_Procedure_Call_Statement
(Loc
,
176 New_Occurrence_Of
(Shared_Var_Assign_Proc
(Ent
), Loc
),
177 Parameter_Associations
=> Empty_List
));
181 ---------------------
182 -- Build_Full_Name --
183 ---------------------
185 procedure Build_Full_Name
190 procedure Build_Name
(E
: Entity_Id
);
191 -- This is a recursive routine used to construct the fully
192 -- qualified string name of the package corresponding to the
195 procedure Build_Name
(E
: Entity_Id
) is
197 if Scope
(E
) /= Standard_Standard
then
198 Build_Name
(Scope
(E
));
199 Store_String_Char
('.');
202 Get_Decoded_Name_String
(Chars
(E
));
203 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
212 ------------------------------------
213 -- Expand_Shared_Passive_Variable --
214 ------------------------------------
216 procedure Expand_Shared_Passive_Variable
(N
: Node_Id
) is
217 Typ
: constant Entity_Id
:= Etype
(N
);
220 -- Nothing to do for protected or limited objects
222 if Is_Limited_Type
(Typ
) or else Is_Concurrent_Type
(Typ
) then
225 -- If we are on the left hand side of an assignment, then we add
226 -- the write call after the assignment.
228 elsif On_Lhs_Of_Assignment
(N
) then
231 -- If we are a parameter for an out or in out formal, then put
232 -- the read before and the write after.
234 elsif Is_Out_Actual
(N
) then
238 -- All other cases are simple reads
243 end Expand_Shared_Passive_Variable
;
249 function Is_Out_Actual
(N
: Node_Id
) return Boolean is
250 Parnt
: constant Node_Id
:= Parent
(N
);
256 if (Nkind
(Parnt
) = N_Indexed_Component
258 Nkind
(Parnt
) = N_Selected_Component
)
259 and then N
= Prefix
(Parnt
)
261 return Is_Out_Actual
(Parnt
);
263 elsif Nkind
(Parnt
) = N_Parameter_Association
264 and then N
= Explicit_Actual_Parameter
(Parnt
)
266 Call
:= Parent
(Parnt
);
268 elsif Nkind
(Parnt
) = N_Procedure_Call_Statement
then
275 -- Fall here if we are definitely a parameter
277 Actual
:= First_Actual
(Call
);
278 Formal
:= First_Formal
(Entity
(Name
(Call
)));
282 if Ekind
(Formal
) /= E_In_Parameter
then
290 Actual
:= Next_Actual
(Actual
);
291 Formal
:= Next_Formal
(Formal
);
296 ---------------------------
297 -- Make_Shared_Var_Procs --
298 ---------------------------
300 procedure Make_Shared_Var_Procs
(N
: Node_Id
) is
301 Loc
: constant Source_Ptr
:= Sloc
(N
);
302 Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
303 Typ
: constant Entity_Id
:= Etype
(Ent
);
307 Assign_Proc
: constant Entity_Id
:=
308 Make_Defining_Identifier
(Loc
,
309 Chars
=> New_External_Name
(Chars
(Ent
), 'A'));
311 Read_Proc
: constant Entity_Id
:=
312 Make_Defining_Identifier
(Loc
,
313 Chars
=> New_External_Name
(Chars
(Ent
), 'R'));
317 -- Start of processing for Make_Shared_Var_Procs
320 Build_Full_Name
(Ent
, Vnm
);
322 -- We turn off Shared_Passive during construction and analysis of
323 -- the assign and read routines, to avoid improper attempts to
324 -- process the variable references within these procedures.
326 Set_Is_Shared_Passive
(Ent
, False);
328 -- Construct assignment routine
331 -- S : Ada.Streams.Stream_IO.Stream_Access;
333 -- S := Shared_Var_WOpen ("pkg.var");
334 -- typ'Write (S, var);
335 -- Shared_Var_Close (S);
338 S
:= Make_Defining_Identifier
(Loc
, Name_uS
);
341 Make_Attribute_Reference
(Loc
,
342 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
343 Attribute_Name
=> Name_Write
,
344 Expressions
=> New_List
(
345 New_Reference_To
(S
, Loc
),
346 New_Occurrence_Of
(Ent
, Loc
)));
348 Set_OK_For_Stream
(Atr
, True);
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 Set_OK_For_Stream
(Atr
, True);
414 Insert_After_And_Analyze
(N
,
415 Make_Subprogram_Body
(Loc
,
417 Make_Procedure_Specification
(Loc
,
418 Defining_Unit_Name
=> Read_Proc
),
420 -- S : Ada.Streams.Stream_IO.Stream_Access;
422 Declarations
=> New_List
(
423 Make_Object_Declaration
(Loc
,
424 Defining_Identifier
=> S
,
426 New_Occurrence_Of
(RTE
(RE_Stream_Access
), Loc
))),
428 Handled_Statement_Sequence
=>
429 Make_Handled_Sequence_Of_Statements
(Loc
,
430 Statements
=> New_List
(
432 -- S := Shared_Var_ROpen ("pkg.var");
434 Make_Assignment_Statement
(Loc
,
435 Name
=> New_Reference_To
(S
, Loc
),
437 Make_Function_Call
(Loc
,
440 (RTE
(RE_Shared_Var_ROpen
), Loc
),
441 Parameter_Associations
=> New_List
(
442 Make_String_Literal
(Loc
, Vnm
)))),
446 Make_Implicit_If_Statement
(N
,
449 Left_Opnd
=> New_Reference_To
(S
, Loc
),
450 Right_Opnd
=> Make_Null
(Loc
)),
452 Then_Statements
=> New_List
(
454 -- typ'Read (S, Var);
458 -- Shared_Var_Close (S);
460 Make_Procedure_Call_Statement
(Loc
,
463 (RTE
(RE_Shared_Var_Close
), Loc
),
464 Parameter_Associations
=>
465 New_List
(New_Reference_To
(S
, Loc
)))))))));
467 Set_Is_Shared_Passive
(Ent
, True);
468 Set_Shared_Var_Assign_Proc
(Ent
, Assign_Proc
);
469 Set_Shared_Var_Read_Proc
(Ent
, Read_Proc
);
470 end Make_Shared_Var_Procs
;
472 --------------------------
473 -- On_Lhs_Of_Assignment --
474 --------------------------
476 function On_Lhs_Of_Assignment
(N
: Node_Id
) return Boolean is
477 P
: constant Node_Id
:= Parent
(N
);
480 if Nkind
(P
) = N_Assignment_Statement
then
488 elsif (Nkind
(P
) = N_Indexed_Component
490 Nkind
(P
) = N_Selected_Component
)
491 and then N
= Prefix
(P
)
493 return On_Lhs_Of_Assignment
(P
);
498 end On_Lhs_Of_Assignment
;