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