|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ C H 2 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Checks; use Checks;
|
|
|
28 with Debug; use Debug;
|
|
|
29 with Einfo; use Einfo;
|
|
|
30 with Elists; use Elists;
|
|
|
31 with Exp_Smem; use Exp_Smem;
|
|
|
32 with Exp_Tss; use Exp_Tss;
|
|
|
33 with Exp_Util; use Exp_Util;
|
|
|
34 with Namet; use Namet;
|
|
|
35 with Nmake; use Nmake;
|
|
|
36 with Opt; use Opt;
|
|
|
37 with Output; use Output;
|
|
|
38 with Sem; use Sem;
|
|
|
39 with Sem_Eval; use Sem_Eval;
|
|
|
40 with Sem_Res; use Sem_Res;
|
|
|
41 with Sem_Util; use Sem_Util;
|
|
|
42 with Sem_Warn; use Sem_Warn;
|
|
|
43 with Sinfo; use Sinfo;
|
|
|
44 with Sinput; use Sinput;
|
|
|
45 with Snames; use Snames;
|
|
|
46 with Tbuild; use Tbuild;
|
|
|
47
|
|
|
48 package body Exp_Ch2 is
|
|
|
49
|
|
|
50 -----------------------
|
|
|
51 -- Local Subprograms --
|
|
|
52 -----------------------
|
|
|
53
|
|
|
54 procedure Expand_Current_Value (N : Node_Id);
|
|
|
55 -- N is a node for a variable whose Current_Value field is set. If N is
|
|
|
56 -- node is for a discrete type, replaces node with a copy of the referenced
|
|
|
57 -- value. This provides a limited form of value propagation for variables
|
|
|
58 -- which are initialized or assigned not been further modified at the time
|
|
|
59 -- of reference. The call has no effect if the Current_Value refers to a
|
|
|
60 -- conditional with condition other than equality.
|
|
|
61
|
|
|
62 procedure Expand_Discriminant (N : Node_Id);
|
|
|
63 -- An occurrence of a discriminant within a discriminated type is replaced
|
|
|
64 -- with the corresponding discriminal, that is to say the formal parameter
|
|
|
65 -- of the initialization procedure for the type that is associated with
|
|
|
66 -- that particular discriminant. This replacement is not performed for
|
|
|
67 -- discriminants of records that appear in constraints of component of the
|
|
|
68 -- record, because Gigi uses the discriminant name to retrieve its value.
|
|
|
69 -- In the other hand, it has to be performed for default expressions of
|
|
|
70 -- components because they are used in the record init procedure. See Einfo
|
|
|
71 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
|
|
|
72 -- discriminants of tasks and protected types, the transformation is more
|
|
|
73 -- complex when it occurs within a default expression for an entry or
|
|
|
74 -- protected operation. The corresponding default_expression_function has
|
|
|
75 -- an additional parameter which is the target of an entry call, and the
|
|
|
76 -- discriminant of the task must be replaced with a reference to the
|
|
|
77 -- discriminant of that formal parameter.
|
|
|
78
|
|
|
79 procedure Expand_Entity_Reference (N : Node_Id);
|
|
|
80 -- Common processing for expansion of identifiers and expanded names
|
|
|
81 -- Dispatches to specific expansion procedures.
|
|
|
82
|
|
|
83 procedure Expand_Entry_Index_Parameter (N : Node_Id);
|
|
|
84 -- A reference to the identifier in the entry index specification of an
|
|
|
85 -- entry body is modified to a reference to a constant definition equal to
|
|
|
86 -- the index of the entry family member being called. This constant is
|
|
|
87 -- calculated as part of the elaboration of the expanded code for the body,
|
|
|
88 -- and is calculated from the object-wide entry index returned by Next_
|
|
|
89 -- Entry_Call.
|
|
|
90
|
|
|
91 procedure Expand_Entry_Parameter (N : Node_Id);
|
|
|
92 -- A reference to an entry parameter is modified to be a reference to the
|
|
|
93 -- corresponding component of the entry parameter record that is passed by
|
|
|
94 -- the runtime to the accept body procedure.
|
|
|
95
|
|
|
96 procedure Expand_Formal (N : Node_Id);
|
|
|
97 -- A reference to a formal parameter of a protected subprogram is expanded
|
|
|
98 -- into the corresponding formal of the unprotected procedure used to
|
|
|
99 -- represent the operation within the protected object. In other cases
|
|
|
100 -- Expand_Formal is a no-op.
|
|
|
101
|
|
|
102 procedure Expand_Protected_Component (N : Node_Id);
|
|
|
103 -- A reference to a private component of a protected type is expanded into
|
|
|
104 -- a reference to the corresponding prival in the current protected entry
|
|
|
105 -- or subprogram.
|
|
|
106
|
|
|
107 procedure Expand_Renaming (N : Node_Id);
|
|
|
108 -- For renamings, just replace the identifier by the corresponding
|
|
|
109 -- named expression. Note that this has been evaluated (see routine
|
|
|
110 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
|
|
|
111 -- the correct renaming semantics.
|
|
|
112
|
|
|
113 --------------------------
|
|
|
114 -- Expand_Current_Value --
|
|
|
115 --------------------------
|
|
|
116
|
|
|
117 procedure Expand_Current_Value (N : Node_Id) is
|
|
|
118 Loc : constant Source_Ptr := Sloc (N);
|
|
|
119 E : constant Entity_Id := Entity (N);
|
|
|
120 CV : constant Node_Id := Current_Value (E);
|
|
|
121 T : constant Entity_Id := Etype (N);
|
|
|
122 Val : Node_Id;
|
|
|
123 Op : Node_Kind;
|
|
|
124
|
|
|
125 -- Start of processing for Expand_Current_Value
|
|
|
126
|
|
|
127 begin
|
|
|
128 if True
|
|
|
129
|
|
|
130 -- No replacement if value raises constraint error
|
|
|
131
|
|
|
132 and then Nkind (CV) /= N_Raise_Constraint_Error
|
|
|
133
|
|
|
134 -- Do this only for discrete types
|
|
|
135
|
|
|
136 and then Is_Discrete_Type (T)
|
|
|
137
|
|
|
138 -- Do not replace biased types, since it is problematic to
|
|
|
139 -- consistently generate a sensible constant value in this case.
|
|
|
140
|
|
|
141 and then not Has_Biased_Representation (T)
|
|
|
142
|
|
|
143 -- Do not replace lvalues
|
|
|
144
|
|
|
145 and then not May_Be_Lvalue (N)
|
|
|
146
|
|
|
147 -- Check that entity is suitable for replacement
|
|
|
148
|
|
|
149 and then OK_To_Do_Constant_Replacement (E)
|
|
|
150
|
|
|
151 -- Do not replace occurrences in pragmas (where names typically
|
|
|
152 -- appear not as values, but as simply names. If there are cases
|
|
|
153 -- where values are required, it is only a very minor efficiency
|
|
|
154 -- issue that they do not get replaced when they could be).
|
|
|
155
|
|
|
156 and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
|
|
|
157
|
|
|
158 -- Do not replace the prefixes of attribute references, since this
|
|
|
159 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
|
|
|
160 -- Name_Asm_Output, don't do replacement anywhere, since we can have
|
|
|
161 -- lvalue references in the arguments.
|
|
|
162
|
|
|
163 and then not (Nkind (Parent (N)) = N_Attribute_Reference
|
|
|
164 and then
|
|
|
165 (Nam_In (Attribute_Name (Parent (N)),
|
|
|
166 Name_Asm_Input,
|
|
|
167 Name_Asm_Output)
|
|
|
168 or else Prefix (Parent (N)) = N))
|
|
|
169
|
|
|
170 then
|
|
|
171 -- Case of Current_Value is a compile time known value
|
|
|
172
|
|
|
173 if Nkind (CV) in N_Subexpr then
|
|
|
174 Val := CV;
|
|
|
175
|
|
|
176 -- Case of Current_Value is an if expression reference
|
|
|
177
|
|
|
178 else
|
|
|
179 Get_Current_Value_Condition (N, Op, Val);
|
|
|
180
|
|
|
181 if Op /= N_Op_Eq then
|
|
|
182 return;
|
|
|
183 end if;
|
|
|
184 end if;
|
|
|
185
|
|
|
186 -- If constant value is an occurrence of an enumeration literal,
|
|
|
187 -- then we just make another occurrence of the same literal.
|
|
|
188
|
|
|
189 if Is_Entity_Name (Val)
|
|
|
190 and then Ekind (Entity (Val)) = E_Enumeration_Literal
|
|
|
191 then
|
|
|
192 Rewrite (N,
|
|
|
193 Unchecked_Convert_To (T,
|
|
|
194 New_Occurrence_Of (Entity (Val), Loc)));
|
|
|
195
|
|
|
196 -- If constant is of a character type, just make an appropriate
|
|
|
197 -- character literal, which will get the proper type.
|
|
|
198
|
|
|
199 elsif Is_Character_Type (T) then
|
|
|
200 Rewrite (N,
|
|
|
201 Make_Character_Literal (Loc,
|
|
|
202 Chars => Chars (Val),
|
|
|
203 Char_Literal_Value => Expr_Rep_Value (Val)));
|
|
|
204
|
|
|
205 -- If constant is of an integer type, just make an appropriate
|
|
|
206 -- integer literal, which will get the proper type.
|
|
|
207
|
|
|
208 elsif Is_Integer_Type (T) then
|
|
|
209 Rewrite (N,
|
|
|
210 Make_Integer_Literal (Loc,
|
|
|
211 Intval => Expr_Rep_Value (Val)));
|
|
|
212
|
|
|
213 -- Otherwise do unchecked conversion of value to right type
|
|
|
214
|
|
|
215 else
|
|
|
216 Rewrite (N,
|
|
|
217 Unchecked_Convert_To (T,
|
|
|
218 Make_Integer_Literal (Loc,
|
|
|
219 Intval => Expr_Rep_Value (Val))));
|
|
|
220 end if;
|
|
|
221
|
|
|
222 Analyze_And_Resolve (N, T);
|
|
|
223 Set_Is_Static_Expression (N, False);
|
|
|
224 end if;
|
|
|
225 end Expand_Current_Value;
|
|
|
226
|
|
|
227 -------------------------
|
|
|
228 -- Expand_Discriminant --
|
|
|
229 -------------------------
|
|
|
230
|
|
|
231 procedure Expand_Discriminant (N : Node_Id) is
|
|
|
232 Scop : constant Entity_Id := Scope (Entity (N));
|
|
|
233 P : Node_Id := N;
|
|
|
234 Parent_P : Node_Id := Parent (P);
|
|
|
235 In_Entry : Boolean := False;
|
|
|
236
|
|
|
237 begin
|
|
|
238 -- The Incomplete_Or_Private_Kind happens while resolving the
|
|
|
239 -- discriminant constraint involved in a derived full type,
|
|
|
240 -- such as:
|
|
|
241
|
|
|
242 -- type D is private;
|
|
|
243 -- type D(C : ...) is new T(C);
|
|
|
244
|
|
|
245 if Ekind (Scop) = E_Record_Type
|
|
|
246 or Ekind (Scop) in Incomplete_Or_Private_Kind
|
|
|
247 then
|
|
|
248 -- Find the origin by walking up the tree till the component
|
|
|
249 -- declaration
|
|
|
250
|
|
|
251 while Present (Parent_P)
|
|
|
252 and then Nkind (Parent_P) /= N_Component_Declaration
|
|
|
253 loop
|
|
|
254 P := Parent_P;
|
|
|
255 Parent_P := Parent (P);
|
|
|
256 end loop;
|
|
|
257
|
|
|
258 -- If the discriminant reference was part of the default expression
|
|
|
259 -- it has to be "discriminalized"
|
|
|
260
|
|
|
261 if Present (Parent_P) and then P = Expression (Parent_P) then
|
|
|
262 Set_Entity (N, Discriminal (Entity (N)));
|
|
|
263 end if;
|
|
|
264
|
|
|
265 elsif Is_Concurrent_Type (Scop) then
|
|
|
266 while Present (Parent_P)
|
|
|
267 and then Nkind (Parent_P) /= N_Subprogram_Body
|
|
|
268 loop
|
|
|
269 P := Parent_P;
|
|
|
270
|
|
|
271 if Nkind (P) = N_Entry_Declaration then
|
|
|
272 In_Entry := True;
|
|
|
273 end if;
|
|
|
274
|
|
|
275 Parent_P := Parent (Parent_P);
|
|
|
276 end loop;
|
|
|
277
|
|
|
278 -- If the discriminant occurs within the default expression for a
|
|
|
279 -- formal of an entry or protected operation, replace it with a
|
|
|
280 -- reference to the discriminant of the formal of the enclosing
|
|
|
281 -- operation.
|
|
|
282
|
|
|
283 if Present (Parent_P)
|
|
|
284 and then Present (Corresponding_Spec (Parent_P))
|
|
|
285 then
|
|
|
286 declare
|
|
|
287 Loc : constant Source_Ptr := Sloc (N);
|
|
|
288 D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
|
|
|
289 Formal : constant Entity_Id := First_Formal (D_Fun);
|
|
|
290 New_N : Node_Id;
|
|
|
291 Disc : Entity_Id;
|
|
|
292
|
|
|
293 begin
|
|
|
294 -- Verify that we are within the body of an entry or protected
|
|
|
295 -- operation. Its first formal parameter is the synchronized
|
|
|
296 -- type itself.
|
|
|
297
|
|
|
298 if Present (Formal)
|
|
|
299 and then Etype (Formal) = Scope (Entity (N))
|
|
|
300 then
|
|
|
301 Disc := CR_Discriminant (Entity (N));
|
|
|
302
|
|
|
303 New_N :=
|
|
|
304 Make_Selected_Component (Loc,
|
|
|
305 Prefix => New_Occurrence_Of (Formal, Loc),
|
|
|
306 Selector_Name => New_Occurrence_Of (Disc, Loc));
|
|
|
307
|
|
|
308 Set_Etype (New_N, Etype (N));
|
|
|
309 Rewrite (N, New_N);
|
|
|
310
|
|
|
311 else
|
|
|
312 Set_Entity (N, Discriminal (Entity (N)));
|
|
|
313 end if;
|
|
|
314 end;
|
|
|
315
|
|
|
316 elsif Nkind (Parent (N)) = N_Range
|
|
|
317 and then In_Entry
|
|
|
318 then
|
|
|
319 Set_Entity (N, CR_Discriminant (Entity (N)));
|
|
|
320
|
|
|
321 -- Finally, if the entity is the discriminant of the original
|
|
|
322 -- type declaration, and we are within the initialization
|
|
|
323 -- procedure for a task, the designated entity is the
|
|
|
324 -- discriminal of the task body. This can happen when the
|
|
|
325 -- argument of pragma Task_Name mentions a discriminant,
|
|
|
326 -- because the pragma is analyzed in the task declaration
|
|
|
327 -- but is expanded in the call to Create_Task in the init_proc.
|
|
|
328
|
|
|
329 elsif Within_Init_Proc then
|
|
|
330 Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));
|
|
|
331 else
|
|
|
332 Set_Entity (N, Discriminal (Entity (N)));
|
|
|
333 end if;
|
|
|
334
|
|
|
335 else
|
|
|
336 Set_Entity (N, Discriminal (Entity (N)));
|
|
|
337 end if;
|
|
|
338 end Expand_Discriminant;
|
|
|
339
|
|
|
340 -----------------------------
|
|
|
341 -- Expand_Entity_Reference --
|
|
|
342 -----------------------------
|
|
|
343
|
|
|
344 procedure Expand_Entity_Reference (N : Node_Id) is
|
|
|
345 E : constant Entity_Id := Entity (N);
|
|
|
346
|
|
|
347 begin
|
|
|
348 -- Defend against errors
|
|
|
349
|
|
|
350 if No (E) then
|
|
|
351 Check_Error_Detected;
|
|
|
352 return;
|
|
|
353 end if;
|
|
|
354
|
|
|
355 if Ekind (E) = E_Discriminant then
|
|
|
356 Expand_Discriminant (N);
|
|
|
357
|
|
|
358 elsif Is_Entry_Formal (E) then
|
|
|
359 Expand_Entry_Parameter (N);
|
|
|
360
|
|
|
361 elsif Is_Protected_Component (E) then
|
|
|
362 if No_Run_Time_Mode then
|
|
|
363 return;
|
|
|
364 else
|
|
|
365 Expand_Protected_Component (N);
|
|
|
366 end if;
|
|
|
367
|
|
|
368 elsif Ekind (E) = E_Entry_Index_Parameter then
|
|
|
369 Expand_Entry_Index_Parameter (N);
|
|
|
370
|
|
|
371 elsif Is_Formal (E) then
|
|
|
372 Expand_Formal (N);
|
|
|
373
|
|
|
374 elsif Is_Renaming_Of_Object (E) then
|
|
|
375 Expand_Renaming (N);
|
|
|
376
|
|
|
377 elsif Ekind (E) = E_Variable
|
|
|
378 and then Is_Shared_Passive (E)
|
|
|
379 then
|
|
|
380 Expand_Shared_Passive_Variable (N);
|
|
|
381 end if;
|
|
|
382
|
|
|
383 -- Test code for implementing the pragma Reviewable requirement of
|
|
|
384 -- classifying reads of scalars as referencing potentially uninitialized
|
|
|
385 -- objects or not.
|
|
|
386
|
|
|
387 if Debug_Flag_XX
|
|
|
388 and then Is_Scalar_Type (Etype (N))
|
|
|
389 and then (Is_Assignable (E) or else Is_Constant_Object (E))
|
|
|
390 and then Comes_From_Source (N)
|
|
|
391 and then Is_LHS (N) = No
|
|
|
392 and then not Is_Actual_Out_Parameter (N)
|
|
|
393 and then (Nkind (Parent (N)) /= N_Attribute_Reference
|
|
|
394 or else Attribute_Name (Parent (N)) /= Name_Valid)
|
|
|
395 then
|
|
|
396 Write_Location (Sloc (N));
|
|
|
397 Write_Str (": Read from scalar """);
|
|
|
398 Write_Name (Chars (N));
|
|
|
399 Write_Str ("""");
|
|
|
400
|
|
|
401 if Is_Known_Valid (E) then
|
|
|
402 Write_Str (", Is_Known_Valid");
|
|
|
403 end if;
|
|
|
404
|
|
|
405 Write_Eol;
|
|
|
406 end if;
|
|
|
407
|
|
|
408 -- Set Atomic_Sync_Required if necessary for atomic variable. Note that
|
|
|
409 -- this processing does NOT apply to Volatile_Full_Access variables.
|
|
|
410
|
|
|
411 if Nkind_In (N, N_Identifier, N_Expanded_Name)
|
|
|
412 and then Ekind (E) = E_Variable
|
|
|
413 and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
|
|
|
414 then
|
|
|
415 declare
|
|
|
416 Set : Boolean;
|
|
|
417
|
|
|
418 begin
|
|
|
419 -- If variable is atomic, but type is not, setting depends on
|
|
|
420 -- disable/enable state for the variable.
|
|
|
421
|
|
|
422 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
|
|
|
423 Set := not Atomic_Synchronization_Disabled (E);
|
|
|
424
|
|
|
425 -- If variable is not atomic, but its type is atomic, setting
|
|
|
426 -- depends on disable/enable state for the type.
|
|
|
427
|
|
|
428 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
|
|
|
429 Set := not Atomic_Synchronization_Disabled (Etype (E));
|
|
|
430
|
|
|
431 -- Else both variable and type are atomic (see outer if), and we
|
|
|
432 -- disable if either variable or its type have sync disabled.
|
|
|
433
|
|
|
434 else
|
|
|
435 Set := (not Atomic_Synchronization_Disabled (E))
|
|
|
436 and then
|
|
|
437 (not Atomic_Synchronization_Disabled (Etype (E)));
|
|
|
438 end if;
|
|
|
439
|
|
|
440 -- Set flag if required
|
|
|
441
|
|
|
442 if Set then
|
|
|
443 Activate_Atomic_Synchronization (N);
|
|
|
444 end if;
|
|
|
445 end;
|
|
|
446 end if;
|
|
|
447
|
|
|
448 -- Interpret possible Current_Value for variable case
|
|
|
449
|
|
|
450 if Is_Assignable (E)
|
|
|
451 and then Present (Current_Value (E))
|
|
|
452 then
|
|
|
453 Expand_Current_Value (N);
|
|
|
454
|
|
|
455 -- We do want to warn for the case of a boolean variable (not a
|
|
|
456 -- boolean constant) whose value is known at compile time.
|
|
|
457
|
|
|
458 if Is_Boolean_Type (Etype (N)) then
|
|
|
459 Warn_On_Known_Condition (N);
|
|
|
460 end if;
|
|
|
461
|
|
|
462 -- Don't mess with Current_Value for compile time known values. Not
|
|
|
463 -- only is it unnecessary, but we could disturb an indication of a
|
|
|
464 -- static value, which could cause semantic trouble.
|
|
|
465
|
|
|
466 elsif Compile_Time_Known_Value (N) then
|
|
|
467 null;
|
|
|
468
|
|
|
469 -- Interpret possible Current_Value for constant case
|
|
|
470
|
|
|
471 elsif Is_Constant_Object (E)
|
|
|
472 and then Present (Current_Value (E))
|
|
|
473 then
|
|
|
474 Expand_Current_Value (N);
|
|
|
475 end if;
|
|
|
476 end Expand_Entity_Reference;
|
|
|
477
|
|
|
478 ----------------------------------
|
|
|
479 -- Expand_Entry_Index_Parameter --
|
|
|
480 ----------------------------------
|
|
|
481
|
|
|
482 procedure Expand_Entry_Index_Parameter (N : Node_Id) is
|
|
|
483 Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
|
|
|
484 begin
|
|
|
485 Set_Entity (N, Index_Con);
|
|
|
486 Set_Etype (N, Etype (Index_Con));
|
|
|
487 end Expand_Entry_Index_Parameter;
|
|
|
488
|
|
|
489 ----------------------------
|
|
|
490 -- Expand_Entry_Parameter --
|
|
|
491 ----------------------------
|
|
|
492
|
|
|
493 procedure Expand_Entry_Parameter (N : Node_Id) is
|
|
|
494 Loc : constant Source_Ptr := Sloc (N);
|
|
|
495 Ent_Formal : constant Entity_Id := Entity (N);
|
|
|
496 Ent_Spec : constant Entity_Id := Scope (Ent_Formal);
|
|
|
497 Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec);
|
|
|
498 Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec);
|
|
|
499 Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
|
|
|
500 P_Comp_Ref : Entity_Id;
|
|
|
501
|
|
|
502 function In_Assignment_Context (N : Node_Id) return Boolean;
|
|
|
503 -- Check whether this is a context in which the entry formal may be
|
|
|
504 -- assigned to.
|
|
|
505
|
|
|
506 ---------------------------
|
|
|
507 -- In_Assignment_Context --
|
|
|
508 ---------------------------
|
|
|
509
|
|
|
510 function In_Assignment_Context (N : Node_Id) return Boolean is
|
|
|
511 begin
|
|
|
512 -- Case of use in a call
|
|
|
513
|
|
|
514 -- ??? passing a formal as actual for a mode IN formal is
|
|
|
515 -- considered as an assignment?
|
|
|
516
|
|
|
517 if Nkind_In (Parent (N), N_Procedure_Call_Statement,
|
|
|
518 N_Entry_Call_Statement)
|
|
|
519 or else (Nkind (Parent (N)) = N_Assignment_Statement
|
|
|
520 and then N = Name (Parent (N)))
|
|
|
521 then
|
|
|
522 return True;
|
|
|
523
|
|
|
524 -- Case of a parameter association: climb up to enclosing call
|
|
|
525
|
|
|
526 elsif Nkind (Parent (N)) = N_Parameter_Association then
|
|
|
527 return In_Assignment_Context (Parent (N));
|
|
|
528
|
|
|
529 -- Case of a selected component, indexed component or slice prefix:
|
|
|
530 -- climb up the tree, unless the prefix is of an access type (in
|
|
|
531 -- which case there is an implicit dereference, and the formal itself
|
|
|
532 -- is not being assigned to).
|
|
|
533
|
|
|
534 elsif Nkind_In (Parent (N), N_Selected_Component,
|
|
|
535 N_Indexed_Component,
|
|
|
536 N_Slice)
|
|
|
537 and then N = Prefix (Parent (N))
|
|
|
538 and then not Is_Access_Type (Etype (N))
|
|
|
539 and then In_Assignment_Context (Parent (N))
|
|
|
540 then
|
|
|
541 return True;
|
|
|
542
|
|
|
543 else
|
|
|
544 return False;
|
|
|
545 end if;
|
|
|
546 end In_Assignment_Context;
|
|
|
547
|
|
|
548 -- Start of processing for Expand_Entry_Parameter
|
|
|
549
|
|
|
550 begin
|
|
|
551 if Is_Task_Type (Scope (Ent_Spec))
|
|
|
552 and then Comes_From_Source (Ent_Formal)
|
|
|
553 then
|
|
|
554 -- Before replacing the formal with the local renaming that is used
|
|
|
555 -- in the accept block, note if this is an assignment context, and
|
|
|
556 -- note the modification to avoid spurious warnings, because the
|
|
|
557 -- original entity is not used further. If formal is unconstrained,
|
|
|
558 -- we also generate an extra parameter to hold the Constrained
|
|
|
559 -- attribute of the actual. No renaming is generated for this flag.
|
|
|
560
|
|
|
561 -- Calling Note_Possible_Modification in the expander is dubious,
|
|
|
562 -- because this generates a cross-reference entry, and should be
|
|
|
563 -- done during semantic processing so it is called in -gnatc mode???
|
|
|
564
|
|
|
565 if Ekind (Entity (N)) /= E_In_Parameter
|
|
|
566 and then In_Assignment_Context (N)
|
|
|
567 then
|
|
|
568 Note_Possible_Modification (N, Sure => True);
|
|
|
569 end if;
|
|
|
570 end if;
|
|
|
571
|
|
|
572 -- What we need is a reference to the corresponding component of the
|
|
|
573 -- parameter record object. The Accept_Address field of the entry entity
|
|
|
574 -- references the address variable that contains the address of the
|
|
|
575 -- accept parameters record. We first have to do an unchecked conversion
|
|
|
576 -- to turn this into a pointer to the parameter record and then we
|
|
|
577 -- select the required parameter field.
|
|
|
578
|
|
|
579 -- The same processing applies to protected entries, where the Accept_
|
|
|
580 -- Address is also the address of the Parameters record.
|
|
|
581
|
|
|
582 P_Comp_Ref :=
|
|
|
583 Make_Selected_Component (Loc,
|
|
|
584 Prefix =>
|
|
|
585 Make_Explicit_Dereference (Loc,
|
|
|
586 Unchecked_Convert_To (Parm_Type,
|
|
|
587 New_Occurrence_Of (Addr_Ent, Loc))),
|
|
|
588 Selector_Name =>
|
|
|
589 New_Occurrence_Of (Entry_Component (Ent_Formal), Loc));
|
|
|
590
|
|
|
591 -- For all types of parameters, the constructed parameter record object
|
|
|
592 -- contains a pointer to the parameter. Thus we must dereference them to
|
|
|
593 -- access them (this will often be redundant, since the dereference is
|
|
|
594 -- implicit, but no harm is done by making it explicit).
|
|
|
595
|
|
|
596 Rewrite (N,
|
|
|
597 Make_Explicit_Dereference (Loc, P_Comp_Ref));
|
|
|
598
|
|
|
599 Analyze (N);
|
|
|
600 end Expand_Entry_Parameter;
|
|
|
601
|
|
|
602 -------------------
|
|
|
603 -- Expand_Formal --
|
|
|
604 -------------------
|
|
|
605
|
|
|
606 procedure Expand_Formal (N : Node_Id) is
|
|
|
607 E : constant Entity_Id := Entity (N);
|
|
|
608 Scop : constant Entity_Id := Scope (E);
|
|
|
609
|
|
|
610 begin
|
|
|
611 -- Check whether the subprogram of which this is a formal is
|
|
|
612 -- a protected operation. The initialization procedure for
|
|
|
613 -- the corresponding record type is not itself a protected operation.
|
|
|
614
|
|
|
615 if Is_Protected_Type (Scope (Scop))
|
|
|
616 and then not Is_Init_Proc (Scop)
|
|
|
617 and then Present (Protected_Formal (E))
|
|
|
618 then
|
|
|
619 Set_Entity (N, Protected_Formal (E));
|
|
|
620 end if;
|
|
|
621 end Expand_Formal;
|
|
|
622
|
|
|
623 ----------------------------
|
|
|
624 -- Expand_N_Expanded_Name --
|
|
|
625 ----------------------------
|
|
|
626
|
|
|
627 procedure Expand_N_Expanded_Name (N : Node_Id) is
|
|
|
628 begin
|
|
|
629 Expand_Entity_Reference (N);
|
|
|
630 end Expand_N_Expanded_Name;
|
|
|
631
|
|
|
632 -------------------------
|
|
|
633 -- Expand_N_Identifier --
|
|
|
634 -------------------------
|
|
|
635
|
|
|
636 procedure Expand_N_Identifier (N : Node_Id) is
|
|
|
637 begin
|
|
|
638 Expand_Entity_Reference (N);
|
|
|
639 end Expand_N_Identifier;
|
|
|
640
|
|
|
641 ---------------------------
|
|
|
642 -- Expand_N_Real_Literal --
|
|
|
643 ---------------------------
|
|
|
644
|
|
|
645 procedure Expand_N_Real_Literal (N : Node_Id) is
|
|
|
646 pragma Unreferenced (N);
|
|
|
647
|
|
|
648 begin
|
|
|
649 -- Historically, this routine existed because there were expansion
|
|
|
650 -- requirements for Vax real literals, but now Vax real literals
|
|
|
651 -- are now handled by gigi, so this routine no longer does anything.
|
|
|
652
|
|
|
653 null;
|
|
|
654 end Expand_N_Real_Literal;
|
|
|
655
|
|
|
656 --------------------------------
|
|
|
657 -- Expand_Protected_Component --
|
|
|
658 --------------------------------
|
|
|
659
|
|
|
660 procedure Expand_Protected_Component (N : Node_Id) is
|
|
|
661
|
|
|
662 function Inside_Eliminated_Body return Boolean;
|
|
|
663 -- Determine whether the current entity is inside a subprogram or an
|
|
|
664 -- entry which has been marked as eliminated.
|
|
|
665
|
|
|
666 ----------------------------
|
|
|
667 -- Inside_Eliminated_Body --
|
|
|
668 ----------------------------
|
|
|
669
|
|
|
670 function Inside_Eliminated_Body return Boolean is
|
|
|
671 S : Entity_Id := Current_Scope;
|
|
|
672
|
|
|
673 begin
|
|
|
674 while Present (S) loop
|
|
|
675 if (Ekind (S) = E_Entry
|
|
|
676 or else Ekind (S) = E_Entry_Family
|
|
|
677 or else Ekind (S) = E_Function
|
|
|
678 or else Ekind (S) = E_Procedure)
|
|
|
679 and then Is_Eliminated (S)
|
|
|
680 then
|
|
|
681 return True;
|
|
|
682 end if;
|
|
|
683
|
|
|
684 S := Scope (S);
|
|
|
685 end loop;
|
|
|
686
|
|
|
687 return False;
|
|
|
688 end Inside_Eliminated_Body;
|
|
|
689
|
|
|
690 -- Start of processing for Expand_Protected_Component
|
|
|
691
|
|
|
692 begin
|
|
|
693 -- Eliminated bodies are not expanded and thus do not need privals
|
|
|
694
|
|
|
695 if not Inside_Eliminated_Body then
|
|
|
696 declare
|
|
|
697 Priv : constant Entity_Id := Prival (Entity (N));
|
|
|
698 begin
|
|
|
699 Set_Entity (N, Priv);
|
|
|
700 Set_Etype (N, Etype (Priv));
|
|
|
701 end;
|
|
|
702 end if;
|
|
|
703 end Expand_Protected_Component;
|
|
|
704
|
|
|
705 ---------------------
|
|
|
706 -- Expand_Renaming --
|
|
|
707 ---------------------
|
|
|
708
|
|
|
709 procedure Expand_Renaming (N : Node_Id) is
|
|
|
710 E : constant Entity_Id := Entity (N);
|
|
|
711 T : constant Entity_Id := Etype (N);
|
|
|
712
|
|
|
713 begin
|
|
|
714 Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
|
|
|
715
|
|
|
716 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
|
|
|
717 -- at the top level. This is needed in the packed case since we
|
|
|
718 -- specifically avoided expanding packed array references when the
|
|
|
719 -- renaming declaration was analyzed.
|
|
|
720
|
|
|
721 Reset_Analyzed_Flags (N);
|
|
|
722 Analyze_And_Resolve (N, T);
|
|
|
723 end Expand_Renaming;
|
|
|
724
|
|
|
725 ------------------
|
|
|
726 -- Param_Entity --
|
|
|
727 ------------------
|
|
|
728
|
|
|
729 -- This would be trivial, simply a test for an identifier that was a
|
|
|
730 -- reference to a formal, if it were not for the fact that a previous call
|
|
|
731 -- to Expand_Entry_Parameter will have modified the reference to the
|
|
|
732 -- identifier. A formal of a protected entity is rewritten as
|
|
|
733
|
|
|
734 -- typ!(recobj).rec.all'Constrained
|
|
|
735
|
|
|
736 -- where rec is a selector whose Entry_Formal link points to the formal
|
|
|
737
|
|
|
738 -- If the type of the entry parameter has a representation clause, then an
|
|
|
739 -- extra temp is involved (see below).
|
|
|
740
|
|
|
741 -- For a formal of a task entity, the formal is rewritten as a local
|
|
|
742 -- renaming.
|
|
|
743
|
|
|
744 -- In addition, a formal that is marked volatile because it is aliased
|
|
|
745 -- through an address clause is rewritten as dereference as well.
|
|
|
746
|
|
|
747 function Param_Entity (N : Node_Id) return Entity_Id is
|
|
|
748 Renamed_Obj : Node_Id;
|
|
|
749
|
|
|
750 begin
|
|
|
751 -- Simple reference case
|
|
|
752
|
|
|
753 if Nkind_In (N, N_Identifier, N_Expanded_Name) then
|
|
|
754 if Is_Formal (Entity (N)) then
|
|
|
755 return Entity (N);
|
|
|
756
|
|
|
757 -- Handle renamings of formal parameters and formals of tasks that
|
|
|
758 -- are rewritten as renamings.
|
|
|
759
|
|
|
760 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
|
|
|
761 Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
|
|
|
762
|
|
|
763 if Is_Entity_Name (Renamed_Obj)
|
|
|
764 and then Is_Formal (Entity (Renamed_Obj))
|
|
|
765 then
|
|
|
766 return Entity (Renamed_Obj);
|
|
|
767
|
|
|
768 elsif
|
|
|
769 Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
|
|
|
770 then
|
|
|
771 return Entity (N);
|
|
|
772 end if;
|
|
|
773 end if;
|
|
|
774
|
|
|
775 else
|
|
|
776 if Nkind (N) = N_Explicit_Dereference then
|
|
|
777 declare
|
|
|
778 P : Node_Id := Prefix (N);
|
|
|
779 S : Node_Id;
|
|
|
780 E : Entity_Id;
|
|
|
781 Decl : Node_Id;
|
|
|
782
|
|
|
783 begin
|
|
|
784 -- If the type of an entry parameter has a representation
|
|
|
785 -- clause, then the prefix is not a selected component, but
|
|
|
786 -- instead a reference to a temp pointing at the selected
|
|
|
787 -- component. In this case, set P to be the initial value of
|
|
|
788 -- that temp.
|
|
|
789
|
|
|
790 if Nkind (P) = N_Identifier then
|
|
|
791 E := Entity (P);
|
|
|
792
|
|
|
793 if Ekind (E) = E_Constant then
|
|
|
794 Decl := Parent (E);
|
|
|
795
|
|
|
796 if Nkind (Decl) = N_Object_Declaration then
|
|
|
797 P := Expression (Decl);
|
|
|
798 end if;
|
|
|
799 end if;
|
|
|
800 end if;
|
|
|
801
|
|
|
802 if Nkind (P) = N_Selected_Component then
|
|
|
803 S := Selector_Name (P);
|
|
|
804
|
|
|
805 if Present (Entry_Formal (Entity (S))) then
|
|
|
806 return Entry_Formal (Entity (S));
|
|
|
807 end if;
|
|
|
808
|
|
|
809 elsif Nkind (Original_Node (N)) = N_Identifier then
|
|
|
810 return Param_Entity (Original_Node (N));
|
|
|
811 end if;
|
|
|
812 end;
|
|
|
813 end if;
|
|
|
814 end if;
|
|
|
815
|
|
|
816 return (Empty);
|
|
|
817 end Param_Entity;
|
|
|
818
|
|
|
819 end Exp_Ch2;
|
