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