]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C H 2 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Atree; use Atree; |
27 | with Checks; use Checks; | |
28 | with Debug; use Debug; | |
29 | with Einfo; use Einfo; | |
76f9c7f4 | 30 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
31 | with Einfo.Utils; use Einfo.Utils; |
32 | with Elists; use Elists; | |
33 | with Exp_Smem; use Exp_Smem; | |
34 | with Exp_Tss; use Exp_Tss; | |
35 | with Exp_Util; use Exp_Util; | |
36 | with Namet; use Namet; | |
37 | with Nmake; use Nmake; | |
38 | with Opt; use Opt; | |
39 | with Output; use Output; | |
40 | with Sem; use Sem; | |
41 | with Sem_Eval; use Sem_Eval; | |
42 | with Sem_Res; use Sem_Res; | |
43 | with Sem_Util; use Sem_Util; | |
44 | with Sem_Warn; use Sem_Warn; | |
45 | with Sinfo; use Sinfo; | |
46 | with Sinfo.Nodes; use Sinfo.Nodes; | |
47 | with Sinfo.Utils; use Sinfo.Utils; | |
48 | with Sinput; use Sinput; | |
49 | with Snames; use Snames; | |
50 | with Tbuild; use Tbuild; | |
70482933 RK |
51 | |
52 | package body Exp_Ch2 is | |
53 | ||
54 | ----------------------- | |
55 | -- Local Subprograms -- | |
56 | ----------------------- | |
57 | ||
fbf5a39b | 58 | procedure Expand_Current_Value (N : Node_Id); |
ba673907 JM |
59 | -- N is a node for a variable whose Current_Value field is set. If N is |
60 | -- node is for a discrete type, replaces node with a copy of the referenced | |
61 | -- value. This provides a limited form of value propagation for variables | |
62 | -- which are initialized or assigned not been further modified at the time | |
63 | -- of reference. The call has no effect if the Current_Value refers to a | |
64 | -- conditional with condition other than equality. | |
fbf5a39b | 65 | |
70482933 | 66 | procedure Expand_Discriminant (N : Node_Id); |
44d6a706 | 67 | -- An occurrence of a discriminant within a discriminated type is replaced |
70482933 RK |
68 | -- with the corresponding discriminal, that is to say the formal parameter |
69 | -- of the initialization procedure for the type that is associated with | |
70 | -- that particular discriminant. This replacement is not performed for | |
71 | -- discriminants of records that appear in constraints of component of the | |
72 | -- record, because Gigi uses the discriminant name to retrieve its value. | |
73 | -- In the other hand, it has to be performed for default expressions of | |
ba673907 JM |
74 | -- components because they are used in the record init procedure. See Einfo |
75 | -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For | |
76 | -- discriminants of tasks and protected types, the transformation is more | |
77 | -- complex when it occurs within a default expression for an entry or | |
78 | -- protected operation. The corresponding default_expression_function has | |
79 | -- an additional parameter which is the target of an entry call, and the | |
80 | -- discriminant of the task must be replaced with a reference to the | |
70482933 RK |
81 | -- discriminant of that formal parameter. |
82 | ||
83 | procedure Expand_Entity_Reference (N : Node_Id); | |
84 | -- Common processing for expansion of identifiers and expanded names | |
d705ba78 | 85 | -- Dispatches to specific expansion procedures. |
70482933 RK |
86 | |
87 | procedure Expand_Entry_Index_Parameter (N : Node_Id); | |
45fc7ddb HK |
88 | -- A reference to the identifier in the entry index specification of an |
89 | -- entry body is modified to a reference to a constant definition equal to | |
90 | -- the index of the entry family member being called. This constant is | |
91 | -- calculated as part of the elaboration of the expanded code for the body, | |
92 | -- and is calculated from the object-wide entry index returned by Next_ | |
93 | -- Entry_Call. | |
70482933 RK |
94 | |
95 | procedure Expand_Entry_Parameter (N : Node_Id); | |
ba673907 JM |
96 | -- A reference to an entry parameter is modified to be a reference to the |
97 | -- corresponding component of the entry parameter record that is passed by | |
d766cee3 | 98 | -- the runtime to the accept body procedure. |
70482933 RK |
99 | |
100 | procedure Expand_Formal (N : Node_Id); | |
ba673907 | 101 | -- A reference to a formal parameter of a protected subprogram is expanded |
d705ba78 RD |
102 | -- into the corresponding formal of the unprotected procedure used to |
103 | -- represent the operation within the protected object. In other cases | |
d766cee3 | 104 | -- Expand_Formal is a no-op. |
70482933 | 105 | |
45fc7ddb HK |
106 | procedure Expand_Protected_Component (N : Node_Id); |
107 | -- A reference to a private component of a protected type is expanded into | |
108 | -- a reference to the corresponding prival in the current protected entry | |
109 | -- or subprogram. | |
70482933 RK |
110 | |
111 | procedure Expand_Renaming (N : Node_Id); | |
112 | -- For renamings, just replace the identifier by the corresponding | |
d705ba78 | 113 | -- named expression. Note that this has been evaluated (see routine |
70482933 RK |
114 | -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives |
115 | -- the correct renaming semantics. | |
116 | ||
fbf5a39b AC |
117 | -------------------------- |
118 | -- Expand_Current_Value -- | |
119 | -------------------------- | |
120 | ||
121 | procedure Expand_Current_Value (N : Node_Id) is | |
122 | Loc : constant Source_Ptr := Sloc (N); | |
123 | E : constant Entity_Id := Entity (N); | |
124 | CV : constant Node_Id := Current_Value (E); | |
125 | T : constant Entity_Id := Etype (N); | |
126 | Val : Node_Id; | |
127 | Op : Node_Kind; | |
128 | ||
fbf5a39b AC |
129 | begin |
130 | if True | |
131 | ||
5d09245e AC |
132 | -- No replacement if value raises constraint error |
133 | ||
134 | and then Nkind (CV) /= N_Raise_Constraint_Error | |
135 | ||
fbf5a39b AC |
136 | -- Do this only for discrete types |
137 | ||
138 | and then Is_Discrete_Type (T) | |
139 | ||
140 | -- Do not replace biased types, since it is problematic to | |
141 | -- consistently generate a sensible constant value in this case. | |
142 | ||
143 | and then not Has_Biased_Representation (T) | |
144 | ||
145 | -- Do not replace lvalues | |
146 | ||
d705ba78 | 147 | and then not May_Be_Lvalue (N) |
fbf5a39b | 148 | |
ba673907 | 149 | -- Check that entity is suitable for replacement |
fbf5a39b | 150 | |
ba673907 | 151 | and then OK_To_Do_Constant_Replacement (E) |
fbf5a39b AC |
152 | |
153 | -- Do not replace occurrences in pragmas (where names typically | |
154 | -- appear not as values, but as simply names. If there are cases | |
155 | -- where values are required, it is only a very minor efficiency | |
156 | -- issue that they do not get replaced when they could be). | |
157 | ||
158 | and then Nkind (Parent (N)) /= N_Pragma_Argument_Association | |
9f4fd324 | 159 | |
d766cee3 RD |
160 | -- Do not replace the prefixes of attribute references, since this |
161 | -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and | |
162 | -- Name_Asm_Output, don't do replacement anywhere, since we can have | |
163 | -- lvalue references in the arguments. | |
9f4fd324 AC |
164 | |
165 | and then not (Nkind (Parent (N)) = N_Attribute_Reference | |
b69cd36a | 166 | and then |
4a08c95c AC |
167 | (Attribute_Name (Parent (N)) in Name_Asm_Input |
168 | | Name_Asm_Output | |
b69cd36a | 169 | or else Prefix (Parent (N)) = N)) |
fbf5a39b AC |
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 | ||
9b16cb57 | 176 | -- Case of Current_Value is an if expression reference |
fbf5a39b AC |
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, | |
f3d0f304 | 187 | -- then we just make another occurrence of the same literal. |
fbf5a39b AC |
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 | ||
825da0d2 EB |
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 | |
b98bd80d RD |
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 | |
fbf5a39b AC |
214 | |
215 | else | |
216 | Rewrite (N, | |
217 | Unchecked_Convert_To (T, | |
b98bd80d RD |
218 | Make_Integer_Literal (Loc, |
219 | Intval => Expr_Rep_Value (Val)))); | |
fbf5a39b AC |
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 | ||
70482933 RK |
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 | |
70482933 RK |
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 | ||
ba673907 | 278 | -- If the discriminant occurs within the default expression for a |
4017021b AC |
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. | |
70482933 RK |
282 | |
283 | if Present (Parent_P) | |
284 | and then Present (Corresponding_Spec (Parent_P)) | |
285 | then | |
70482933 RK |
286 | declare |
287 | Loc : constant Source_Ptr := Sloc (N); | |
fbf5a39b AC |
288 | D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P); |
289 | Formal : constant Entity_Id := First_Formal (D_Fun); | |
70482933 RK |
290 | New_N : Node_Id; |
291 | Disc : Entity_Id; | |
292 | ||
293 | begin | |
4017021b AC |
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. | |
70482933 RK |
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))); | |
c5326593 ES |
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)))); | |
70482933 RK |
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 | |
eb0d08ad SB |
345 | |
346 | function Is_Object_Renaming_Name (N : Node_Id) return Boolean; | |
347 | -- Indicates that N occurs (after accounting for qualified expressions | |
348 | -- and type conversions) as the name of an object renaming declaration. | |
349 | -- We don't want to fold values in that case. | |
350 | ||
351 | ----------------------------- | |
352 | -- Is_Object_Renaming_Name -- | |
353 | ----------------------------- | |
354 | ||
355 | function Is_Object_Renaming_Name (N : Node_Id) return Boolean is | |
356 | Trailer : Node_Id := N; | |
357 | Rover : Node_Id; | |
358 | begin | |
359 | loop | |
360 | Rover := Parent (Trailer); | |
361 | case Nkind (Rover) is | |
362 | when N_Qualified_Expression | N_Type_Conversion => | |
363 | -- Conservative for type conversions; only necessary if | |
364 | -- conversion does not introduce a new object (as opposed | |
365 | -- to a new view of an existing object). | |
366 | null; | |
367 | when N_Object_Renaming_Declaration => | |
368 | return Trailer = Name (Rover); | |
369 | when others => | |
370 | return False; -- the usual case | |
371 | end case; | |
372 | Trailer := Rover; | |
373 | end loop; | |
374 | end Is_Object_Renaming_Name; | |
375 | ||
376 | -- Local variables | |
377 | ||
70482933 RK |
378 | E : constant Entity_Id := Entity (N); |
379 | ||
eb0d08ad SB |
380 | -- Start of processing for Expand_Entity_Reference |
381 | ||
70482933 | 382 | begin |
07fc65c4 GB |
383 | -- Defend against errors |
384 | ||
ee2ba856 AC |
385 | if No (E) then |
386 | Check_Error_Detected; | |
07fc65c4 GB |
387 | return; |
388 | end if; | |
389 | ||
70482933 RK |
390 | if Ekind (E) = E_Discriminant then |
391 | Expand_Discriminant (N); | |
392 | ||
393 | elsif Is_Entry_Formal (E) then | |
394 | Expand_Entry_Parameter (N); | |
395 | ||
45fc7ddb | 396 | elsif Is_Protected_Component (E) then |
fbf5a39b AC |
397 | if No_Run_Time_Mode then |
398 | return; | |
12b4d338 AC |
399 | else |
400 | Expand_Protected_Component (N); | |
fbf5a39b AC |
401 | end if; |
402 | ||
70482933 RK |
403 | elsif Ekind (E) = E_Entry_Index_Parameter then |
404 | Expand_Entry_Index_Parameter (N); | |
405 | ||
406 | elsif Is_Formal (E) then | |
407 | Expand_Formal (N); | |
408 | ||
409 | elsif Is_Renaming_Of_Object (E) then | |
410 | Expand_Renaming (N); | |
411 | ||
412 | elsif Ekind (E) = E_Variable | |
413 | and then Is_Shared_Passive (E) | |
414 | then | |
415 | Expand_Shared_Passive_Variable (N); | |
d705ba78 | 416 | end if; |
fbf5a39b | 417 | |
75ba322d AC |
418 | -- Test code for implementing the pragma Reviewable requirement of |
419 | -- classifying reads of scalars as referencing potentially uninitialized | |
420 | -- objects or not. | |
421 | ||
422 | if Debug_Flag_XX | |
423 | and then Is_Scalar_Type (Etype (N)) | |
424 | and then (Is_Assignable (E) or else Is_Constant_Object (E)) | |
425 | and then Comes_From_Source (N) | |
a54ffd6c | 426 | and then Is_LHS (N) = No |
75ba322d AC |
427 | and then not Is_Actual_Out_Parameter (N) |
428 | and then (Nkind (Parent (N)) /= N_Attribute_Reference | |
9337aa0a | 429 | or else Attribute_Name (Parent (N)) /= Name_Valid) |
75ba322d AC |
430 | then |
431 | Write_Location (Sloc (N)); | |
432 | Write_Str (": Read from scalar """); | |
433 | Write_Name (Chars (N)); | |
434 | Write_Str (""""); | |
9337aa0a | 435 | |
75ba322d AC |
436 | if Is_Known_Valid (E) then |
437 | Write_Str (", Is_Known_Valid"); | |
438 | end if; | |
9337aa0a | 439 | |
75ba322d AC |
440 | Write_Eol; |
441 | end if; | |
442 | ||
f280dd8f RD |
443 | -- Set Atomic_Sync_Required if necessary for atomic variable. Note that |
444 | -- this processing does NOT apply to Volatile_Full_Access variables. | |
12b4d338 | 445 | |
4a08c95c | 446 | if Nkind (N) in N_Identifier | N_Expanded_Name |
8751a35c | 447 | and then Ekind (E) = E_Variable |
fb5d63c6 RD |
448 | and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) |
449 | then | |
12b4d338 | 450 | declare |
2e885a6f | 451 | Set : Boolean; |
12b4d338 AC |
452 | |
453 | begin | |
fb5d63c6 RD |
454 | -- If variable is atomic, but type is not, setting depends on |
455 | -- disable/enable state for the variable. | |
12b4d338 | 456 | |
4c318253 | 457 | if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then |
12b4d338 | 458 | Set := not Atomic_Synchronization_Disabled (E); |
fb5d63c6 RD |
459 | |
460 | -- If variable is not atomic, but its type is atomic, setting | |
461 | -- depends on disable/enable state for the type. | |
462 | ||
463 | elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then | |
464 | Set := not Atomic_Synchronization_Disabled (Etype (E)); | |
465 | ||
466 | -- Else both variable and type are atomic (see outer if), and we | |
467 | -- disable if either variable or its type have sync disabled. | |
468 | ||
469 | else | |
470 | Set := (not Atomic_Synchronization_Disabled (E)) | |
471 | and then | |
472 | (not Atomic_Synchronization_Disabled (Etype (E))); | |
12b4d338 AC |
473 | end if; |
474 | ||
475 | -- Set flag if required | |
476 | ||
477 | if Set then | |
4c318253 | 478 | Activate_Atomic_Synchronization (N); |
12b4d338 AC |
479 | end if; |
480 | end; | |
481 | end if; | |
482 | ||
eb0d08ad SB |
483 | -- Interpret possible Current_Value for variable case. The |
484 | -- Is_Object_Renaming_Name test is needed for cases such as | |
485 | -- X : Integer := 1; | |
486 | -- Y : Integer renames Integer'(X); | |
487 | -- where the value of Y is changed by any subsequent assignments to X. | |
488 | -- In cases like this, we do not want to use Current_Value even though | |
489 | -- it is available. | |
d705ba78 | 490 | |
75ba322d | 491 | if Is_Assignable (E) |
fbf5a39b | 492 | and then Present (Current_Value (E)) |
eb0d08ad | 493 | and then not Is_Object_Renaming_Name (N) |
fbf5a39b AC |
494 | then |
495 | Expand_Current_Value (N); | |
496 | ||
ba673907 JM |
497 | -- We do want to warn for the case of a boolean variable (not a |
498 | -- boolean constant) whose value is known at compile time. | |
fbf5a39b AC |
499 | |
500 | if Is_Boolean_Type (Etype (N)) then | |
501 | Warn_On_Known_Condition (N); | |
502 | end if; | |
d705ba78 RD |
503 | |
504 | -- Don't mess with Current_Value for compile time known values. Not | |
505 | -- only is it unnecessary, but we could disturb an indication of a | |
506 | -- static value, which could cause semantic trouble. | |
507 | ||
508 | elsif Compile_Time_Known_Value (N) then | |
509 | null; | |
510 | ||
511 | -- Interpret possible Current_Value for constant case | |
512 | ||
45fc7ddb | 513 | elsif Is_Constant_Object (E) |
d705ba78 RD |
514 | and then Present (Current_Value (E)) |
515 | then | |
516 | Expand_Current_Value (N); | |
70482933 RK |
517 | end if; |
518 | end Expand_Entity_Reference; | |
519 | ||
520 | ---------------------------------- | |
521 | -- Expand_Entry_Index_Parameter -- | |
522 | ---------------------------------- | |
523 | ||
524 | procedure Expand_Entry_Index_Parameter (N : Node_Id) is | |
45fc7ddb | 525 | Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); |
70482933 | 526 | begin |
45fc7ddb HK |
527 | Set_Entity (N, Index_Con); |
528 | Set_Etype (N, Etype (Index_Con)); | |
70482933 RK |
529 | end Expand_Entry_Index_Parameter; |
530 | ||
531 | ---------------------------- | |
532 | -- Expand_Entry_Parameter -- | |
533 | ---------------------------- | |
534 | ||
535 | procedure Expand_Entry_Parameter (N : Node_Id) is | |
536 | Loc : constant Source_Ptr := Sloc (N); | |
537 | Ent_Formal : constant Entity_Id := Entity (N); | |
538 | Ent_Spec : constant Entity_Id := Scope (Ent_Formal); | |
539 | Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); | |
540 | Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); | |
541 | Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack)); | |
542 | P_Comp_Ref : Entity_Id; | |
543 | ||
fbf5a39b | 544 | function In_Assignment_Context (N : Node_Id) return Boolean; |
ba673907 JM |
545 | -- Check whether this is a context in which the entry formal may be |
546 | -- assigned to. | |
fbf5a39b AC |
547 | |
548 | --------------------------- | |
549 | -- In_Assignment_Context -- | |
550 | --------------------------- | |
551 | ||
552 | function In_Assignment_Context (N : Node_Id) return Boolean is | |
553 | begin | |
d766cee3 RD |
554 | -- Case of use in a call |
555 | ||
556 | -- ??? passing a formal as actual for a mode IN formal is | |
557 | -- considered as an assignment? | |
558 | ||
4a08c95c AC |
559 | if Nkind (Parent (N)) in |
560 | N_Procedure_Call_Statement | N_Entry_Call_Statement | |
34a343e6 RD |
561 | or else (Nkind (Parent (N)) = N_Assignment_Statement |
562 | and then N = Name (Parent (N))) | |
fbf5a39b AC |
563 | then |
564 | return True; | |
565 | ||
d766cee3 RD |
566 | -- Case of a parameter association: climb up to enclosing call |
567 | ||
fbf5a39b AC |
568 | elsif Nkind (Parent (N)) = N_Parameter_Association then |
569 | return In_Assignment_Context (Parent (N)); | |
570 | ||
d766cee3 RD |
571 | -- Case of a selected component, indexed component or slice prefix: |
572 | -- climb up the tree, unless the prefix is of an access type (in | |
573 | -- which case there is an implicit dereference, and the formal itself | |
574 | -- is not being assigned to). | |
575 | ||
4a08c95c AC |
576 | elsif Nkind (Parent (N)) in |
577 | N_Selected_Component | N_Indexed_Component | N_Slice | |
d766cee3 RD |
578 | and then N = Prefix (Parent (N)) |
579 | and then not Is_Access_Type (Etype (N)) | |
fbf5a39b AC |
580 | and then In_Assignment_Context (Parent (N)) |
581 | then | |
582 | return True; | |
d766cee3 | 583 | |
fbf5a39b AC |
584 | else |
585 | return False; | |
586 | end if; | |
587 | end In_Assignment_Context; | |
588 | ||
589 | -- Start of processing for Expand_Entry_Parameter | |
590 | ||
70482933 | 591 | begin |
fbf5a39b AC |
592 | if Is_Task_Type (Scope (Ent_Spec)) |
593 | and then Comes_From_Source (Ent_Formal) | |
594 | then | |
ba673907 JM |
595 | -- Before replacing the formal with the local renaming that is used |
596 | -- in the accept block, note if this is an assignment context, and | |
597 | -- note the modification to avoid spurious warnings, because the | |
598 | -- original entity is not used further. If formal is unconstrained, | |
599 | -- we also generate an extra parameter to hold the Constrained | |
600 | -- attribute of the actual. No renaming is generated for this flag. | |
fbf5a39b | 601 | |
b473ab45 | 602 | -- Calling Note_Possible_Modification in the expander is dubious, |
45fc7ddb HK |
603 | -- because this generates a cross-reference entry, and should be |
604 | -- done during semantic processing so it is called in -gnatc mode??? | |
605 | ||
fbf5a39b AC |
606 | if Ekind (Entity (N)) /= E_In_Parameter |
607 | and then In_Assignment_Context (N) | |
608 | then | |
45fc7ddb | 609 | Note_Possible_Modification (N, Sure => True); |
fbf5a39b | 610 | end if; |
fbf5a39b AC |
611 | end if; |
612 | ||
70482933 | 613 | -- What we need is a reference to the corresponding component of the |
ba673907 JM |
614 | -- parameter record object. The Accept_Address field of the entry entity |
615 | -- references the address variable that contains the address of the | |
616 | -- accept parameters record. We first have to do an unchecked conversion | |
617 | -- to turn this into a pointer to the parameter record and then we | |
618 | -- select the required parameter field. | |
70482933 | 619 | |
b474d6c3 ES |
620 | -- The same processing applies to protected entries, where the Accept_ |
621 | -- Address is also the address of the Parameters record. | |
622 | ||
70482933 RK |
623 | P_Comp_Ref := |
624 | Make_Selected_Component (Loc, | |
625 | Prefix => | |
5453d5bd AC |
626 | Make_Explicit_Dereference (Loc, |
627 | Unchecked_Convert_To (Parm_Type, | |
e4494292 | 628 | New_Occurrence_Of (Addr_Ent, Loc))), |
70482933 | 629 | Selector_Name => |
e4494292 | 630 | New_Occurrence_Of (Entry_Component (Ent_Formal), Loc)); |
70482933 | 631 | |
ba673907 JM |
632 | -- For all types of parameters, the constructed parameter record object |
633 | -- contains a pointer to the parameter. Thus we must dereference them to | |
09494c32 AC |
634 | -- access them (this will often be redundant, since the dereference is |
635 | -- implicit, but no harm is done by making it explicit). | |
70482933 RK |
636 | |
637 | Rewrite (N, | |
638 | Make_Explicit_Dereference (Loc, P_Comp_Ref)); | |
639 | ||
640 | Analyze (N); | |
641 | end Expand_Entry_Parameter; | |
642 | ||
643 | ------------------- | |
644 | -- Expand_Formal -- | |
645 | ------------------- | |
646 | ||
647 | procedure Expand_Formal (N : Node_Id) is | |
648 | E : constant Entity_Id := Entity (N); | |
d705ba78 | 649 | Scop : constant Entity_Id := Scope (E); |
70482933 RK |
650 | |
651 | begin | |
d705ba78 RD |
652 | -- Check whether the subprogram of which this is a formal is |
653 | -- a protected operation. The initialization procedure for | |
654 | -- the corresponding record type is not itself a protected operation. | |
655 | ||
656 | if Is_Protected_Type (Scope (Scop)) | |
657 | and then not Is_Init_Proc (Scop) | |
70482933 RK |
658 | and then Present (Protected_Formal (E)) |
659 | then | |
660 | Set_Entity (N, Protected_Formal (E)); | |
661 | end if; | |
662 | end Expand_Formal; | |
663 | ||
664 | ---------------------------- | |
665 | -- Expand_N_Expanded_Name -- | |
666 | ---------------------------- | |
667 | ||
668 | procedure Expand_N_Expanded_Name (N : Node_Id) is | |
669 | begin | |
670 | Expand_Entity_Reference (N); | |
671 | end Expand_N_Expanded_Name; | |
672 | ||
673 | ------------------------- | |
674 | -- Expand_N_Identifier -- | |
675 | ------------------------- | |
676 | ||
677 | procedure Expand_N_Identifier (N : Node_Id) is | |
678 | begin | |
679 | Expand_Entity_Reference (N); | |
680 | end Expand_N_Identifier; | |
681 | ||
682 | --------------------------- | |
683 | -- Expand_N_Real_Literal -- | |
684 | --------------------------- | |
685 | ||
686 | procedure Expand_N_Real_Literal (N : Node_Id) is | |
150ac76e AC |
687 | pragma Unreferenced (N); |
688 | ||
70482933 | 689 | begin |
150ac76e AC |
690 | -- Historically, this routine existed because there were expansion |
691 | -- requirements for Vax real literals, but now Vax real literals | |
692 | -- are now handled by gigi, so this routine no longer does anything. | |
693 | ||
436d9f92 | 694 | null; |
70482933 RK |
695 | end Expand_N_Real_Literal; |
696 | ||
45fc7ddb HK |
697 | -------------------------------- |
698 | -- Expand_Protected_Component -- | |
699 | -------------------------------- | |
70482933 | 700 | |
45fc7ddb | 701 | procedure Expand_Protected_Component (N : Node_Id) is |
70482933 | 702 | |
45fc7ddb HK |
703 | function Inside_Eliminated_Body return Boolean; |
704 | -- Determine whether the current entity is inside a subprogram or an | |
705 | -- entry which has been marked as eliminated. | |
70482933 | 706 | |
45fc7ddb HK |
707 | ---------------------------- |
708 | -- Inside_Eliminated_Body -- | |
709 | ---------------------------- | |
70482933 | 710 | |
45fc7ddb HK |
711 | function Inside_Eliminated_Body return Boolean is |
712 | S : Entity_Id := Current_Scope; | |
70482933 | 713 | |
45fc7ddb HK |
714 | begin |
715 | while Present (S) loop | |
716 | if (Ekind (S) = E_Entry | |
717 | or else Ekind (S) = E_Entry_Family | |
718 | or else Ekind (S) = E_Function | |
719 | or else Ekind (S) = E_Procedure) | |
720 | and then Is_Eliminated (S) | |
70482933 | 721 | then |
45fc7ddb | 722 | return True; |
70482933 RK |
723 | end if; |
724 | ||
45fc7ddb HK |
725 | S := Scope (S); |
726 | end loop; | |
70482933 | 727 | |
45fc7ddb HK |
728 | return False; |
729 | end Inside_Eliminated_Body; | |
70482933 | 730 | |
45fc7ddb | 731 | -- Start of processing for Expand_Protected_Component |
70482933 | 732 | |
45fc7ddb HK |
733 | begin |
734 | -- Eliminated bodies are not expanded and thus do not need privals | |
735 | ||
736 | if not Inside_Eliminated_Body then | |
737 | declare | |
738 | Priv : constant Entity_Id := Prival (Entity (N)); | |
739 | begin | |
740 | Set_Entity (N, Priv); | |
741 | Set_Etype (N, Etype (Priv)); | |
742 | end; | |
743 | end if; | |
744 | end Expand_Protected_Component; | |
70482933 RK |
745 | |
746 | --------------------- | |
747 | -- Expand_Renaming -- | |
748 | --------------------- | |
749 | ||
750 | procedure Expand_Renaming (N : Node_Id) is | |
751 | E : constant Entity_Id := Entity (N); | |
752 | T : constant Entity_Id := Etype (N); | |
753 | ||
754 | begin | |
755 | Rewrite (N, New_Copy_Tree (Renamed_Object (E))); | |
756 | ||
ba673907 JM |
757 | -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed |
758 | -- at the top level. This is needed in the packed case since we | |
759 | -- specifically avoided expanding packed array references when the | |
760 | -- renaming declaration was analyzed. | |
70482933 RK |
761 | |
762 | Reset_Analyzed_Flags (N); | |
763 | Analyze_And_Resolve (N, T); | |
764 | end Expand_Renaming; | |
765 | ||
70482933 | 766 | end Exp_Ch2; |