]>
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 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, 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 | ||
26 | with Atree; use Atree; | |
12b4d338 | 27 | with Checks; use Checks; |
75ba322d | 28 | with Debug; use Debug; |
70482933 RK |
29 | with Einfo; use Einfo; |
30 | with Elists; use Elists; | |
31 | with Exp_Smem; use Exp_Smem; | |
fbf5a39b | 32 | with Exp_Tss; use Exp_Tss; |
70482933 | 33 | with Exp_Util; use Exp_Util; |
d766cee3 | 34 | with Namet; use Namet; |
70482933 | 35 | with Nmake; use Nmake; |
fbf5a39b | 36 | with Opt; use Opt; |
75ba322d | 37 | with Output; use Output; |
70482933 | 38 | with Sem; use Sem; |
fbf5a39b | 39 | with Sem_Eval; use Sem_Eval; |
70482933 RK |
40 | with Sem_Res; use Sem_Res; |
41 | with Sem_Util; use Sem_Util; | |
fbf5a39b | 42 | with Sem_Warn; use Sem_Warn; |
70482933 | 43 | with Sinfo; use Sinfo; |
75ba322d | 44 | with Sinput; use Sinput; |
d766cee3 | 45 | with Snames; use Snames; |
70482933 | 46 | with Tbuild; use Tbuild; |
70482933 RK |
47 | |
48 | package body Exp_Ch2 is | |
49 | ||
50 | ----------------------- | |
51 | -- Local Subprograms -- | |
52 | ----------------------- | |
53 | ||
fbf5a39b | 54 | procedure Expand_Current_Value (N : Node_Id); |
ba673907 JM |
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. | |
fbf5a39b | 61 | |
70482933 | 62 | procedure Expand_Discriminant (N : Node_Id); |
44d6a706 | 63 | -- An occurrence of a discriminant within a discriminated type is replaced |
70482933 RK |
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 | |
ba673907 JM |
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 | |
70482933 RK |
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 | |
d705ba78 | 81 | -- Dispatches to specific expansion procedures. |
70482933 RK |
82 | |
83 | procedure Expand_Entry_Index_Parameter (N : Node_Id); | |
45fc7ddb HK |
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. | |
70482933 RK |
90 | |
91 | procedure Expand_Entry_Parameter (N : Node_Id); | |
ba673907 JM |
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 | |
d766cee3 | 94 | -- the runtime to the accept body procedure. |
70482933 RK |
95 | |
96 | procedure Expand_Formal (N : Node_Id); | |
ba673907 | 97 | -- A reference to a formal parameter of a protected subprogram is expanded |
d705ba78 RD |
98 | -- into the corresponding formal of the unprotected procedure used to |
99 | -- represent the operation within the protected object. In other cases | |
d766cee3 | 100 | -- Expand_Formal is a no-op. |
70482933 | 101 | |
45fc7ddb HK |
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. | |
70482933 RK |
106 | |
107 | procedure Expand_Renaming (N : Node_Id); | |
108 | -- For renamings, just replace the identifier by the corresponding | |
d705ba78 | 109 | -- named expression. Note that this has been evaluated (see routine |
70482933 RK |
110 | -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives |
111 | -- the correct renaming semantics. | |
112 | ||
fbf5a39b AC |
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 | ||
fbf5a39b AC |
125 | -- Start of processing for Expand_Current_Value |
126 | ||
127 | begin | |
128 | if True | |
129 | ||
5d09245e AC |
130 | -- No replacement if value raises constraint error |
131 | ||
132 | and then Nkind (CV) /= N_Raise_Constraint_Error | |
133 | ||
fbf5a39b AC |
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 | ||
d705ba78 | 145 | and then not May_Be_Lvalue (N) |
fbf5a39b | 146 | |
ba673907 | 147 | -- Check that entity is suitable for replacement |
fbf5a39b | 148 | |
ba673907 | 149 | and then OK_To_Do_Constant_Replacement (E) |
fbf5a39b AC |
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 | |
9f4fd324 | 157 | |
d766cee3 RD |
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. | |
9f4fd324 AC |
162 | |
163 | and then not (Nkind (Parent (N)) = N_Attribute_Reference | |
b69cd36a AC |
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)) | |
822033eb | 169 | |
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 | |
345 | E : constant Entity_Id := Entity (N); | |
346 | ||
347 | begin | |
07fc65c4 GB |
348 | -- Defend against errors |
349 | ||
ee2ba856 AC |
350 | if No (E) then |
351 | Check_Error_Detected; | |
07fc65c4 GB |
352 | return; |
353 | end if; | |
354 | ||
70482933 RK |
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 | ||
45fc7ddb | 361 | elsif Is_Protected_Component (E) then |
fbf5a39b AC |
362 | if No_Run_Time_Mode then |
363 | return; | |
12b4d338 AC |
364 | else |
365 | Expand_Protected_Component (N); | |
fbf5a39b AC |
366 | end if; |
367 | ||
70482933 RK |
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); | |
d705ba78 | 381 | end if; |
fbf5a39b | 382 | |
75ba322d AC |
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) | |
a54ffd6c | 391 | and then Is_LHS (N) = No |
75ba322d AC |
392 | and then not Is_Actual_Out_Parameter (N) |
393 | and then (Nkind (Parent (N)) /= N_Attribute_Reference | |
9337aa0a | 394 | or else Attribute_Name (Parent (N)) /= Name_Valid) |
75ba322d AC |
395 | then |
396 | Write_Location (Sloc (N)); | |
397 | Write_Str (": Read from scalar """); | |
398 | Write_Name (Chars (N)); | |
399 | Write_Str (""""); | |
9337aa0a | 400 | |
75ba322d AC |
401 | if Is_Known_Valid (E) then |
402 | Write_Str (", Is_Known_Valid"); | |
403 | end if; | |
9337aa0a | 404 | |
75ba322d AC |
405 | Write_Eol; |
406 | end if; | |
407 | ||
f280dd8f RD |
408 | -- Set Atomic_Sync_Required if necessary for atomic variable. Note that |
409 | -- this processing does NOT apply to Volatile_Full_Access variables. | |
12b4d338 | 410 | |
fb5d63c6 | 411 | if Nkind_In (N, N_Identifier, N_Expanded_Name) |
8751a35c | 412 | and then Ekind (E) = E_Variable |
fb5d63c6 RD |
413 | and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) |
414 | then | |
12b4d338 | 415 | declare |
2e885a6f | 416 | Set : Boolean; |
12b4d338 AC |
417 | |
418 | begin | |
fb5d63c6 RD |
419 | -- If variable is atomic, but type is not, setting depends on |
420 | -- disable/enable state for the variable. | |
12b4d338 | 421 | |
4c318253 | 422 | if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then |
12b4d338 | 423 | Set := not Atomic_Synchronization_Disabled (E); |
fb5d63c6 RD |
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))); | |
12b4d338 AC |
438 | end if; |
439 | ||
440 | -- Set flag if required | |
441 | ||
442 | if Set then | |
4c318253 | 443 | Activate_Atomic_Synchronization (N); |
12b4d338 AC |
444 | end if; |
445 | end; | |
446 | end if; | |
447 | ||
d705ba78 RD |
448 | -- Interpret possible Current_Value for variable case |
449 | ||
75ba322d | 450 | if Is_Assignable (E) |
fbf5a39b | 451 | and then Present (Current_Value (E)) |
fbf5a39b AC |
452 | then |
453 | Expand_Current_Value (N); | |
454 | ||
ba673907 JM |
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. | |
fbf5a39b AC |
457 | |
458 | if Is_Boolean_Type (Etype (N)) then | |
459 | Warn_On_Known_Condition (N); | |
460 | end if; | |
d705ba78 RD |
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 | ||
45fc7ddb | 471 | elsif Is_Constant_Object (E) |
d705ba78 RD |
472 | and then Present (Current_Value (E)) |
473 | then | |
474 | Expand_Current_Value (N); | |
70482933 RK |
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 | |
45fc7ddb | 483 | Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); |
70482933 | 484 | begin |
45fc7ddb HK |
485 | Set_Entity (N, Index_Con); |
486 | Set_Etype (N, Etype (Index_Con)); | |
70482933 RK |
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 | ||
fbf5a39b | 502 | function In_Assignment_Context (N : Node_Id) return Boolean; |
ba673907 JM |
503 | -- Check whether this is a context in which the entry formal may be |
504 | -- assigned to. | |
fbf5a39b AC |
505 | |
506 | --------------------------- | |
507 | -- In_Assignment_Context -- | |
508 | --------------------------- | |
509 | ||
510 | function In_Assignment_Context (N : Node_Id) return Boolean is | |
511 | begin | |
d766cee3 RD |
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 | ||
34a343e6 RD |
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))) | |
fbf5a39b AC |
521 | then |
522 | return True; | |
523 | ||
d766cee3 RD |
524 | -- Case of a parameter association: climb up to enclosing call |
525 | ||
fbf5a39b AC |
526 | elsif Nkind (Parent (N)) = N_Parameter_Association then |
527 | return In_Assignment_Context (Parent (N)); | |
528 | ||
d766cee3 RD |
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 | ||
34a343e6 RD |
534 | elsif Nkind_In (Parent (N), N_Selected_Component, |
535 | N_Indexed_Component, | |
536 | N_Slice) | |
d766cee3 RD |
537 | and then N = Prefix (Parent (N)) |
538 | and then not Is_Access_Type (Etype (N)) | |
fbf5a39b AC |
539 | and then In_Assignment_Context (Parent (N)) |
540 | then | |
541 | return True; | |
d766cee3 | 542 | |
fbf5a39b AC |
543 | else |
544 | return False; | |
545 | end if; | |
546 | end In_Assignment_Context; | |
547 | ||
548 | -- Start of processing for Expand_Entry_Parameter | |
549 | ||
70482933 | 550 | begin |
fbf5a39b AC |
551 | if Is_Task_Type (Scope (Ent_Spec)) |
552 | and then Comes_From_Source (Ent_Formal) | |
553 | then | |
ba673907 JM |
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. | |
fbf5a39b | 560 | |
b473ab45 | 561 | -- Calling Note_Possible_Modification in the expander is dubious, |
45fc7ddb HK |
562 | -- because this generates a cross-reference entry, and should be |
563 | -- done during semantic processing so it is called in -gnatc mode??? | |
564 | ||
fbf5a39b AC |
565 | if Ekind (Entity (N)) /= E_In_Parameter |
566 | and then In_Assignment_Context (N) | |
567 | then | |
45fc7ddb | 568 | Note_Possible_Modification (N, Sure => True); |
fbf5a39b | 569 | end if; |
fbf5a39b AC |
570 | end if; |
571 | ||
70482933 | 572 | -- What we need is a reference to the corresponding component of the |
ba673907 JM |
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. | |
70482933 | 578 | |
b474d6c3 ES |
579 | -- The same processing applies to protected entries, where the Accept_ |
580 | -- Address is also the address of the Parameters record. | |
581 | ||
70482933 RK |
582 | P_Comp_Ref := |
583 | Make_Selected_Component (Loc, | |
584 | Prefix => | |
5453d5bd AC |
585 | Make_Explicit_Dereference (Loc, |
586 | Unchecked_Convert_To (Parm_Type, | |
e4494292 | 587 | New_Occurrence_Of (Addr_Ent, Loc))), |
70482933 | 588 | Selector_Name => |
e4494292 | 589 | New_Occurrence_Of (Entry_Component (Ent_Formal), Loc)); |
70482933 | 590 | |
ba673907 JM |
591 | -- For all types of parameters, the constructed parameter record object |
592 | -- contains a pointer to the parameter. Thus we must dereference them to | |
09494c32 AC |
593 | -- access them (this will often be redundant, since the dereference is |
594 | -- implicit, but no harm is done by making it explicit). | |
70482933 RK |
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); | |
d705ba78 | 608 | Scop : constant Entity_Id := Scope (E); |
70482933 RK |
609 | |
610 | begin | |
d705ba78 RD |
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) | |
70482933 RK |
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 | |
150ac76e AC |
646 | pragma Unreferenced (N); |
647 | ||
70482933 | 648 | begin |
150ac76e AC |
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 | ||
436d9f92 | 653 | null; |
70482933 RK |
654 | end Expand_N_Real_Literal; |
655 | ||
45fc7ddb HK |
656 | -------------------------------- |
657 | -- Expand_Protected_Component -- | |
658 | -------------------------------- | |
70482933 | 659 | |
45fc7ddb | 660 | procedure Expand_Protected_Component (N : Node_Id) is |
70482933 | 661 | |
45fc7ddb HK |
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. | |
70482933 | 665 | |
45fc7ddb HK |
666 | ---------------------------- |
667 | -- Inside_Eliminated_Body -- | |
668 | ---------------------------- | |
70482933 | 669 | |
45fc7ddb HK |
670 | function Inside_Eliminated_Body return Boolean is |
671 | S : Entity_Id := Current_Scope; | |
70482933 | 672 | |
45fc7ddb HK |
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) | |
70482933 | 680 | then |
45fc7ddb | 681 | return True; |
70482933 RK |
682 | end if; |
683 | ||
45fc7ddb HK |
684 | S := Scope (S); |
685 | end loop; | |
70482933 | 686 | |
45fc7ddb HK |
687 | return False; |
688 | end Inside_Eliminated_Body; | |
70482933 | 689 | |
45fc7ddb | 690 | -- Start of processing for Expand_Protected_Component |
70482933 | 691 | |
45fc7ddb HK |
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; | |
70482933 RK |
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 | ||
ba673907 JM |
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. | |
70482933 RK |
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 | |
ba673907 JM |
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 | |
70482933 RK |
733 | |
734 | -- typ!(recobj).rec.all'Constrained | |
735 | ||
736 | -- where rec is a selector whose Entry_Formal link points to the formal | |
d99ff0f4 | 737 | |
f146302c AC |
738 | -- If the type of the entry parameter has a representation clause, then an |
739 | -- extra temp is involved (see below). | |
d99ff0f4 | 740 | |
fbf5a39b AC |
741 | -- For a formal of a task entity, the formal is rewritten as a local |
742 | -- renaming. | |
555360a5 | 743 | |
8a7988f5 AC |
744 | -- In addition, a formal that is marked volatile because it is aliased |
745 | -- through an address clause is rewritten as dereference as well. | |
70482933 RK |
746 | |
747 | function Param_Entity (N : Node_Id) return Entity_Id is | |
d766cee3 RD |
748 | Renamed_Obj : Node_Id; |
749 | ||
70482933 RK |
750 | begin |
751 | -- Simple reference case | |
752 | ||
34a343e6 | 753 | if Nkind_In (N, N_Identifier, N_Expanded_Name) then |
70482933 RK |
754 | if Is_Formal (Entity (N)) then |
755 | return Entity (N); | |
fbf5a39b | 756 | |
d766cee3 RD |
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; | |
70482933 RK |
773 | end if; |
774 | ||
775 | else | |
776 | if Nkind (N) = N_Explicit_Dereference then | |
777 | declare | |
f146302c AC |
778 | P : Node_Id := Prefix (N); |
779 | S : Node_Id; | |
780 | E : Entity_Id; | |
781 | Decl : Node_Id; | |
70482933 RK |
782 | |
783 | begin | |
f146302c AC |
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 | ||
70482933 RK |
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; | |
8a7988f5 AC |
808 | |
809 | elsif Nkind (Original_Node (N)) = N_Identifier then | |
810 | return Param_Entity (Original_Node (N)); | |
70482933 RK |
811 | end if; |
812 | end; | |
813 | end if; | |
814 | end if; | |
815 | ||
816 | return (Empty); | |
817 | end Param_Entity; | |
818 | ||
819 | end Exp_Ch2; |