?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / exp_unst.adb
blobb01cfc13bf96a4aaf1f721535e596bfb702148ec
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ U N S T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2014-2023, 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 Debug; use Debug;
28 with Einfo; use Einfo;
29 with Einfo.Entities; use Einfo.Entities;
30 with Einfo.Utils; use Einfo.Utils;
31 with Elists; use Elists;
32 with Exp_Util; use Exp_Util;
33 with Lib; use Lib;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt;
38 with Output; use Output;
39 with Rtsfind; use Rtsfind;
40 with Sem; use Sem;
41 with Sem_Aux; use Sem_Aux;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Mech; use Sem_Mech;
44 with Sem_Res; use Sem_Res;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Sinfo.Nodes; use Sinfo.Nodes;
48 with Sinfo.Utils; use Sinfo.Utils;
49 with Sinput; use Sinput;
50 with Snames; use Snames;
51 with Stand; use Stand;
52 with Tbuild; use Tbuild;
53 with Uintp; use Uintp;
54
55 package body Exp_Unst is
56
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
60
61 procedure Unnest_Subprogram
62 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False);
63 -- Subp is a library-level subprogram which has nested subprograms, and
64 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
65 -- declares the AREC types and objects, adds assignments to the AREC record
66 -- as required, defines the xxxPTR types for uplevel referenced objects,
67 -- adds the ARECP parameter to all nested subprograms which need it, and
68 -- modifies all uplevel references appropriately. If For_Inline is True,
69 -- we're unnesting this subprogram because it's on the list of inlined
70 -- subprograms and should unnest it despite it not being part of the main
71 -- unit.
72
73 -----------
74 -- Calls --
75 -----------
76
77 -- Table to record calls within the nest being analyzed. These are the
78 -- calls which may need to have an AREC actual added. This table is built
79 -- new for each subprogram nest and cleared at the end of processing each
80 -- subprogram nest.
81
82 type Call_Entry is record
83 N : Node_Id;
84 -- The actual call
85
86 Caller : Entity_Id;
87 -- Entity of the subprogram containing the call (can be at any level)
88
89 Callee : Entity_Id;
90 -- Entity of the subprogram called (always at level 2 or higher). Note
91 -- that in accordance with the basic rules of nesting, the level of To
92 -- is either less than or equal to the level of From, or one greater.
93 end record;
94
95 package Calls is new Table.Table (
96 Table_Component_Type => Call_Entry,
97 Table_Index_Type => Nat,
98 Table_Low_Bound => 1,
99 Table_Initial => 100,
100 Table_Increment => 200,
101 Table_Name => "Unnest_Calls");
102 -- Records each call within the outer subprogram and all nested subprograms
103 -- that are to other subprograms nested within the outer subprogram. These
104 -- are the calls that may need an additional parameter.
105
106 procedure Append_Unique_Call (Call : Call_Entry);
107 -- Append a call entry to the Calls table. A check is made to see if the
108 -- table already contains this entry and if so it has no effect.
109
110 ----------------------------------
111 -- Subprograms For Fat Pointers --
112 ----------------------------------
113
114 function Build_Access_Type_Decl
115 (E : Entity_Id;
116 Scop : Entity_Id) return Node_Id;
117 -- For an uplevel reference that involves an unconstrained array type,
118 -- build an access type declaration for the corresponding activation
119 -- record component. The relevant attributes of the access type are
120 -- set here to avoid a full analysis that would require a scope stack.
121
122 function Needs_Fat_Pointer (E : Entity_Id) return Boolean;
123 -- A formal parameter of an unconstrained array type that appears in an
124 -- uplevel reference requires the construction of an access type, to be
125 -- used in the corresponding component declaration.
126
127 -----------
128 -- Urefs --
129 -----------
130
131 -- Table to record explicit uplevel references to objects (variables,
132 -- constants, formal parameters). These are the references that will
133 -- need rewriting to use the activation table (AREC) pointers. Also
134 -- included are implicit and explicit uplevel references to types, but
135 -- these do not get rewritten by the front end. This table is built new
136 -- for each subprogram nest and cleared at the end of processing each
137 -- subprogram nest.
138
139 type Uref_Entry is record
140 Ref : Node_Id;
141 -- The reference itself. For objects this is always an entity reference
142 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
143 -- flag set and will appear in the Uplevel_Referenced_Entities list of
144 -- the subprogram declaring this entity.
145
146 Ent : Entity_Id;
147 -- The Entity_Id of the uplevel referenced object or type
148
149 Caller : Entity_Id;
150 -- The entity for the subprogram immediately containing this entity
151
152 Callee : Entity_Id;
153 -- The entity for the subprogram containing the referenced entity. Note
154 -- that the level of Callee must be less than the level of Caller, since
155 -- this is an uplevel reference.
156 end record;
157
158 package Urefs is new Table.Table (
159 Table_Component_Type => Uref_Entry,
160 Table_Index_Type => Nat,
161 Table_Low_Bound => 1,
162 Table_Initial => 100,
163 Table_Increment => 200,
164 Table_Name => "Unnest_Urefs");
165
166 ------------------------
167 -- Append_Unique_Call --
168 ------------------------
169
170 procedure Append_Unique_Call (Call : Call_Entry) is
171 begin
172 for J in Calls.First .. Calls.Last loop
173 if Calls.Table (J) = Call then
174 return;
175 end if;
176 end loop;
177
178 Calls.Append (Call);
179 end Append_Unique_Call;
180
181 -----------------------------
182 -- Build_Access_Type_Decl --
183 -----------------------------
184
185 function Build_Access_Type_Decl
186 (E : Entity_Id;
187 Scop : Entity_Id) return Node_Id
188 is
189 Loc : constant Source_Ptr := Sloc (E);
190 Typ : Entity_Id;
191
192 begin
193 Typ := Make_Temporary (Loc, 'S');
194 Mutate_Ekind (Typ, E_General_Access_Type);
195 Set_Etype (Typ, Typ);
196 Set_Scope (Typ, Scop);
197 Set_Directly_Designated_Type (Typ, Etype (E));
198
199 return
200 Make_Full_Type_Declaration (Loc,
201 Defining_Identifier => Typ,
202 Type_Definition =>
203 Make_Access_To_Object_Definition (Loc,
204 Subtype_Indication => New_Occurrence_Of (Etype (E), Loc)));
205 end Build_Access_Type_Decl;
206
207 ---------------
208 -- Get_Level --
209 ---------------
210
211 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
212 Lev : Nat;
213 S : Entity_Id;
214
215 begin
216 Lev := 1;
217 S := Sub;
218 loop
219 if S = Subp then
220 return Lev;
221 else
222 Lev := Lev + 1;
223 S := Enclosing_Subprogram (S);
224 end if;
225 end loop;
226 end Get_Level;
227
228 --------------------------
229 -- In_Synchronized_Unit --
230 --------------------------
231
232 function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is
233 S : Entity_Id := Scope (Subp);
234
235 begin
236 while Present (S) and then S /= Standard_Standard loop
237 if Is_Concurrent_Type (S) then
238 return True;
239
240 elsif Is_Private_Type (S)
241 and then Present (Full_View (S))
242 and then Is_Concurrent_Type (Full_View (S))
243 then
244 return True;
245 end if;
246
247 S := Scope (S);
248 end loop;
249
250 return False;
251 end In_Synchronized_Unit;
252
253 -----------------------
254 -- Needs_Fat_Pointer --
255 -----------------------
256
257 function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
258 Typ : constant Entity_Id := Get_Fullest_View (Etype (E));
259 begin
260 return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
261 end Needs_Fat_Pointer;
262
263 ----------------
264 -- Subp_Index --
265 ----------------
266
267 function Subp_Index (Sub : Entity_Id) return SI_Type is
268 E : Entity_Id := Sub;
269
270 begin
271 pragma Assert (Is_Subprogram (E));
272
273 if Field_Is_Initial_Zero (E, F_Subps_Index)
274 or else Subps_Index (E) = Uint_0
275 then
276 E := Ultimate_Alias (E);
277
278 -- The body of a protected operation has a different name and
279 -- has been scanned at this point, and thus has an entry in the
280 -- subprogram table.
281
282 if E = Sub and then Present (Protected_Body_Subprogram (E)) then
283 E := Protected_Body_Subprogram (E);
284 end if;
285
286 if Ekind (E) = E_Function
287 and then Rewritten_For_C (E)
288 and then Present (Corresponding_Procedure (E))
289 then
290 E := Corresponding_Procedure (E);
291 end if;
292 end if;
293
294 pragma Assert (Subps_Index (E) /= Uint_0);
295 return SI_Type (UI_To_Int (Subps_Index (E)));
296 end Subp_Index;
297
298 -----------------------
299 -- Unnest_Subprogram --
300 -----------------------
301
302 procedure Unnest_Subprogram
303 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False) is
304 function AREC_Name (J : Pos; S : String) return Name_Id;
305 -- Returns name for string ARECjS, where j is the decimal value of j
306
307 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
308 -- Subp is the index of a subprogram which has a Lev greater than 1.
309 -- This function returns the index of the enclosing subprogram which
310 -- will have a Lev value one less than this.
311
312 function Img_Pos (N : Pos) return String;
313 -- Return image of N without leading blank
314
315 function Upref_Name
316 (Ent : Entity_Id;
317 Index : Pos;
318 Clist : List_Id) return Name_Id;
319 -- This function returns the name to be used in the activation record to
320 -- reference the variable uplevel. Clist is the list of components that
321 -- have been created in the activation record so far. Normally the name
322 -- is just a copy of the Chars field of the entity. The exception is
323 -- when the name has already been used, in which case we suffix the name
324 -- with the index value Index to avoid duplication. This happens with
325 -- declare blocks and generic parameters at least.
326
327 ---------------
328 -- AREC_Name --
329 ---------------
330
331 function AREC_Name (J : Pos; S : String) return Name_Id is
332 begin
333 return Name_Find ("AREC" & Img_Pos (J) & S);
334 end AREC_Name;
335
336 --------------------
337 -- Enclosing_Subp --
338 --------------------
339
340 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
341 STJ : Subp_Entry renames Subps.Table (Subp);
342 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
343 begin
344 pragma Assert (STJ.Lev > 1);
345 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
346 return Ret;
347 end Enclosing_Subp;
348
349 -------------
350 -- Img_Pos --
351 -------------
352
353 function Img_Pos (N : Pos) return String is
354 Buf : String (1 .. 20);
355 Ptr : Natural;
356 NV : Nat;
357
358 begin
359 Ptr := Buf'Last;
360 NV := N;
361 while NV /= 0 loop
362 Buf (Ptr) := Character'Val (48 + NV mod 10);
363 Ptr := Ptr - 1;
364 NV := NV / 10;
365 end loop;
366
367 return Buf (Ptr + 1 .. Buf'Last);
368 end Img_Pos;
369
370 ----------------
371 -- Upref_Name --
372 ----------------
373
374 function Upref_Name
375 (Ent : Entity_Id;
376 Index : Pos;
377 Clist : List_Id) return Name_Id
378 is
379 C : Node_Id;
380 begin
381 C := First (Clist);
382 loop
383 if No (C) then
384 return Chars (Ent);
385
386 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
387 return
388 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
389 else
390 Next (C);
391 end if;
392 end loop;
393 end Upref_Name;
394
395 -- Start of processing for Unnest_Subprogram
396
397 begin
398 -- Nothing to do inside a generic (all processing is for instance)
399
400 if Inside_A_Generic then
401 return;
402 end if;
403
404 -- If the main unit is a package body then we need to examine the spec
405 -- to determine whether the main unit is generic (the scope stack is not
406 -- present when this is called on the main unit).
407
408 if not For_Inline
409 and then Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
410 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
411 then
412 return;
413
414 -- Only unnest when generating code for the main source unit or if
415 -- we're unnesting for inline. But in some Annex E cases the Sloc
416 -- points to a different unit, so also make sure that the Parent
417 -- isn't in something that we know we're generating code for.
418
419 elsif not For_Inline
420 and then not In_Extended_Main_Code_Unit (Subp_Body)
421 and then not In_Extended_Main_Code_Unit (Parent (Subp_Body))
422 then
423 return;
424 end if;
425
426 -- This routine is called late, after the scope stack is gone. The
427 -- following creates a suitable dummy scope stack to be used for the
428 -- analyze/expand calls made from this routine.
429
430 Push_Scope (Subp);
431
432 -- First step, we must mark all nested subprograms that require a static
433 -- link (activation record) because either they contain explicit uplevel
434 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
435 -- this point), or they make calls to other subprograms in the same nest
436 -- that require a static link (in which case we set this flag).
437
438 -- This is a recursive definition, and to implement this, we have to
439 -- build a call graph for the set of nested subprograms, and then go
440 -- over this graph to implement recursively the invariant that if a
441 -- subprogram has a call to a subprogram requiring a static link, then
442 -- the calling subprogram requires a static link.
443
444 -- First populate the above tables
445
446 Subps_First := Subps.Last + 1;
447 Calls.Init;
448 Urefs.Init;
449
450 Build_Tables : declare
451 Current_Subprogram : Entity_Id := Empty;
452 -- When we scan a subprogram body, we set Current_Subprogram to the
453 -- corresponding entity. This gets recursively saved and restored.
454
455 function Visit_Node (N : Node_Id) return Traverse_Result;
456 -- Visit a single node in Subp
457
458 -----------
459 -- Visit --
460 -----------
461
462 procedure Visit is new Traverse_Proc (Visit_Node);
463 -- Used to traverse the body of Subp, populating the tables
464
465 ----------------
466 -- Visit_Node --
467 ----------------
468
469 function Visit_Node (N : Node_Id) return Traverse_Result is
470 Ent : Entity_Id;
471 Caller : Entity_Id;
472 Callee : Entity_Id;
473
474 procedure Check_Static_Type
475 (In_T : Entity_Id;
476 N : Node_Id;
477 DT : in out Boolean;
478 Check_Designated : Boolean := False);
479 -- Given a type In_T, checks if it is a static type defined as
480 -- a type with no dynamic bounds in sight. If so, the only
481 -- action is to set Is_Static_Type True for In_T. If In_T is
482 -- not a static type, then all types with dynamic bounds
483 -- associated with In_T are detected, and their bounds are
484 -- marked as uplevel referenced if not at the library level,
485 -- and DT is set True. If N is specified, it's the node that
486 -- will need to be replaced. If not specified, it means we
487 -- can't do a replacement because the bound is implicit.
488
489 -- If Check_Designated is True and In_T or its full view
490 -- is an access type, check whether the designated type
491 -- has dynamic bounds.
492
493 procedure Note_Uplevel_Ref
494 (E : Entity_Id;
495 N : Node_Id;
496 Caller : Entity_Id;
497 Callee : Entity_Id);
498 -- Called when we detect an explicit or implicit uplevel reference
499 -- from within Caller to entity E declared in Callee. E can be a
500 -- an object or a type.
501
502 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
503 -- Enter a subprogram whose body is visible or which is a
504 -- subprogram instance into the subprogram table.
505
506 -----------------------
507 -- Check_Static_Type --
508 -----------------------
509
510 procedure Check_Static_Type
511 (In_T : Entity_Id;
512 N : Node_Id;
513 DT : in out Boolean;
514 Check_Designated : Boolean := False)
515 is
516 T : constant Entity_Id := Get_Fullest_View (In_T);
517
518 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
519 -- N is the bound of a dynamic type. This procedure notes that
520 -- this bound is uplevel referenced, it can handle references
521 -- to entities (typically _FIRST and _LAST entities), and also
522 -- attribute references of the form T'name (name is typically
523 -- FIRST or LAST) where T is the uplevel referenced bound.
524 -- Ref, if Present, is the location of the reference to
525 -- replace.
526
527 ------------------------
528 -- Note_Uplevel_Bound --
529 ------------------------
530
531 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
532 begin
533 -- Entity name case. Make sure that the entity is declared
534 -- in a subprogram. This may not be the case for a type in a
535 -- loop appearing in a precondition.
536 -- Exclude explicitly discriminants (that can appear
537 -- in bounds of discriminated components) and enumeration
538 -- literals.
539
540 if Is_Entity_Name (N) then
541 if Present (Entity (N))
542 and then not Is_Type (Entity (N))
543 and then Present (Enclosing_Subprogram (Entity (N)))
544 and then
545 Ekind (Entity (N))
546 not in E_Discriminant | E_Enumeration_Literal
547 then
548 Note_Uplevel_Ref
549 (E => Entity (N),
550 N => Empty,
551 Caller => Current_Subprogram,
552 Callee => Enclosing_Subprogram (Entity (N)));
553 end if;
554
555 -- Attribute or indexed component case
556
557 elsif Nkind (N) in
558 N_Attribute_Reference | N_Indexed_Component
559 then
560 Note_Uplevel_Bound (Prefix (N), Ref);
561
562 -- The indices of the indexed components, or the
563 -- associated expressions of an attribute reference,
564 -- may also involve uplevel references.
565
566 declare
567 Expr : Node_Id;
568
569 begin
570 Expr := First (Expressions (N));
571 while Present (Expr) loop
572 Note_Uplevel_Bound (Expr, Ref);
573 Next (Expr);
574 end loop;
575 end;
576
577 -- The type of the prefix may be have an uplevel
578 -- reference if this needs bounds.
579
580 if Nkind (N) = N_Attribute_Reference then
581 declare
582 Attr : constant Attribute_Id :=
583 Get_Attribute_Id (Attribute_Name (N));
584 DT : Boolean := False;
585
586 begin
587 if (Attr = Attribute_First
588 or else Attr = Attribute_Last
589 or else Attr = Attribute_Length)
590 and then Is_Constrained (Etype (Prefix (N)))
591 then
592 Check_Static_Type
593 (Etype (Prefix (N)), Empty, DT);
594 end if;
595 end;
596 end if;
597
598 -- Binary operator cases. These can apply to arrays for
599 -- which we may need bounds.
600
601 elsif Nkind (N) in N_Binary_Op then
602 Note_Uplevel_Bound (Left_Opnd (N), Ref);
603 Note_Uplevel_Bound (Right_Opnd (N), Ref);
604
605 -- Unary operator case
606
607 elsif Nkind (N) in N_Unary_Op then
608 Note_Uplevel_Bound (Right_Opnd (N), Ref);
609
610 -- Explicit dereference and selected component case
611
612 elsif Nkind (N) in
613 N_Explicit_Dereference | N_Selected_Component
614 then
615 Note_Uplevel_Bound (Prefix (N), Ref);
616
617 -- Conditional expressions
618
619 elsif Nkind (N) = N_If_Expression then
620 declare
621 Expr : Node_Id;
622
623 begin
624 Expr := First (Expressions (N));
625 while Present (Expr) loop
626 Note_Uplevel_Bound (Expr, Ref);
627 Next (Expr);
628 end loop;
629 end;
630
631 elsif Nkind (N) = N_Case_Expression then
632 declare
633 Alternative : Node_Id;
634
635 begin
636 Note_Uplevel_Bound (Expression (N), Ref);
637
638 Alternative := First (Alternatives (N));
639 while Present (Alternative) loop
640 Note_Uplevel_Bound (Expression (Alternative), Ref);
641 end loop;
642 end;
643
644 -- Conversion case
645
646 elsif Nkind (N) = N_Type_Conversion then
647 Note_Uplevel_Bound (Expression (N), Ref);
648 end if;
649 end Note_Uplevel_Bound;
650
651 -- Start of processing for Check_Static_Type
652
653 begin
654 -- If already marked static, immediate return
655
656 if Is_Static_Type (T) and then not Check_Designated then
657 return;
658 end if;
659
660 -- If the type is at library level, always consider it static,
661 -- since such uplevel references are irrelevant.
662
663 if Is_Library_Level_Entity (T) then
664 Set_Is_Static_Type (T);
665 return;
666 end if;
667
668 -- Otherwise figure out what the story is with this type
669
670 -- For a scalar type, check bounds
671
672 if Is_Scalar_Type (T) then
673
674 -- If both bounds static, then this is a static type
675
676 declare
677 LB : constant Node_Id := Type_Low_Bound (T);
678 UB : constant Node_Id := Type_High_Bound (T);
679
680 begin
681 if not Is_Static_Expression (LB) then
682 Note_Uplevel_Bound (LB, N);
683 DT := True;
684 end if;
685
686 if not Is_Static_Expression (UB) then
687 Note_Uplevel_Bound (UB, N);
688 DT := True;
689 end if;
690 end;
691
692 -- For record type, check all components and discriminant
693 -- constraints if present.
694
695 elsif Is_Record_Type (T) then
696 declare
697 C : Entity_Id;
698 D : Elmt_Id;
699
700 begin
701 C := First_Component_Or_Discriminant (T);
702 while Present (C) loop
703 Check_Static_Type (Etype (C), N, DT);
704 Next_Component_Or_Discriminant (C);
705 end loop;
706
707 if Has_Discriminants (T)
708 and then Present (Discriminant_Constraint (T))
709 then
710 D := First_Elmt (Discriminant_Constraint (T));
711 while Present (D) loop
712 if not Is_Static_Expression (Node (D)) then
713 Note_Uplevel_Bound (Node (D), N);
714 DT := True;
715 end if;
716
717 Next_Elmt (D);
718 end loop;
719 end if;
720 end;
721
722 -- For array type, check index types and component type
723
724 elsif Is_Array_Type (T) then
725 declare
726 IX : Node_Id;
727 begin
728 Check_Static_Type (Component_Type (T), N, DT);
729
730 IX := First_Index (T);
731 while Present (IX) loop
732 Check_Static_Type (Etype (IX), N, DT);
733 Next_Index (IX);
734 end loop;
735 end;
736
737 -- For private type, examine whether full view is static
738
739 elsif Is_Incomplete_Or_Private_Type (T)
740 and then Present (Full_View (T))
741 then
742 Check_Static_Type (Full_View (T), N, DT, Check_Designated);
743
744 if Is_Static_Type (Full_View (T)) then
745 Set_Is_Static_Type (T);
746 end if;
747
748 -- For access types, check designated type when required
749
750 elsif Is_Access_Type (T) and then Check_Designated then
751 Check_Static_Type (Directly_Designated_Type (T), N, DT);
752
753 -- For now, ignore other types
754
755 else
756 return;
757 end if;
758
759 if not DT then
760 Set_Is_Static_Type (T);
761 end if;
762 end Check_Static_Type;
763
764 ----------------------
765 -- Note_Uplevel_Ref --
766 ----------------------
767
768 procedure Note_Uplevel_Ref
769 (E : Entity_Id;
770 N : Node_Id;
771 Caller : Entity_Id;
772 Callee : Entity_Id)
773 is
774 Full_E : Entity_Id := E;
775 begin
776 -- Nothing to do for static type
777
778 if Is_Static_Type (E) then
779 return;
780 end if;
781
782 -- Nothing to do if Caller and Callee are the same
783
784 if Caller = Callee then
785 return;
786
787 -- Callee may be a function that returns an array, and that has
788 -- been rewritten as a procedure. If caller is that procedure,
789 -- nothing to do either.
790
791 elsif Ekind (Callee) = E_Function
792 and then Rewritten_For_C (Callee)
793 and then Corresponding_Procedure (Callee) = Caller
794 then
795 return;
796
797 elsif Ekind (Callee) in E_Entry | E_Entry_Family then
798 return;
799 end if;
800
801 -- We have a new uplevel referenced entity
802
803 if Ekind (E) = E_Constant and then Present (Full_View (E)) then
804 Full_E := Full_View (E);
805 end if;
806
807 -- All we do at this stage is to add the uplevel reference to
808 -- the table. It's too early to do anything else, since this
809 -- uplevel reference may come from an unreachable subprogram
810 -- in which case the entry will be deleted.
811
812 Urefs.Append ((N, Full_E, Caller, Callee));
813 end Note_Uplevel_Ref;
814
815 -------------------------
816 -- Register_Subprogram --
817 -------------------------
818
819 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
820 L : constant Nat := Get_Level (Subp, E);
821
822 begin
823 -- Subprograms declared in tasks and protected types cannot be
824 -- eliminated because calls to them may be in other units, so
825 -- they must be treated as reachable.
826
827 Subps.Append
828 ((Ent => E,
829 Bod => Bod,
830 Lev => L,
831 Reachable => In_Synchronized_Unit (E)
832 or else Address_Taken (E),
833 Uplevel_Ref => L,
834 Declares_AREC => False,
835 Uents => No_Elist,
836 Last => 0,
837 ARECnF => Empty,
838 ARECn => Empty,
839 ARECnT => Empty,
840 ARECnPT => Empty,
841 ARECnP => Empty,
842 ARECnU => Empty));
843
844 Set_Subps_Index (E, UI_From_Int (Subps.Last));
845
846 -- If we marked this reachable because it's in a synchronized
847 -- unit, we have to mark all enclosing subprograms as reachable
848 -- as well. We do the same for subprograms with Address_Taken,
849 -- because otherwise we can run into problems with looking at
850 -- enclosing subprograms in Subps.Table due to their being
851 -- unreachable (the Subp_Index of unreachable subps is later
852 -- set to zero and their entry in Subps.Table is removed).
853
854 if In_Synchronized_Unit (E) or else Address_Taken (E) then
855 declare
856 S : Entity_Id := E;
857
858 begin
859 for J in reverse 1 .. L - 1 loop
860 S := Enclosing_Subprogram (S);
861 Subps.Table (Subp_Index (S)).Reachable := True;
862 end loop;
863 end;
864 end if;
865 end Register_Subprogram;
866
867 -- Start of processing for Visit_Node
868
869 begin
870 case Nkind (N) is
871
872 -- Record a subprogram call
873
874 when N_Function_Call
875 | N_Procedure_Call_Statement
876 =>
877 -- We are only interested in direct calls, not indirect
878 -- calls (where Name (N) is an explicit dereference) at
879 -- least for now!
880
881 if Nkind (Name (N)) in N_Has_Entity then
882 Ent := Entity (Name (N));
883
884 -- We are only interested in calls to subprograms nested
885 -- within Subp. Calls to Subp itself or to subprograms
886 -- outside the nested structure do not affect us.
887
888 if Is_Subprogram (Ent)
889 and then not Is_Generic_Subprogram (Ent)
890 and then not Is_Imported (Ent)
891 and then not Is_Intrinsic_Subprogram (Ent)
892 and then Scope_Within (Ultimate_Alias (Ent), Subp)
893 then
894 Append_Unique_Call ((N, Current_Subprogram, Ent));
895 end if;
896 end if;
897
898 -- For all calls where the formal is an unconstrained array
899 -- and the actual is constrained we need to check the bounds
900 -- for uplevel references.
901
902 declare
903 Actual : Entity_Id;
904 DT : Boolean := False;
905 Formal : Node_Id;
906 Subp : Entity_Id;
907 F_Type : Entity_Id;
908 A_Type : Entity_Id;
909
910 begin
911 if Nkind (Name (N)) = N_Explicit_Dereference then
912 Subp := Etype (Name (N));
913 else
914 Subp := Entity (Name (N));
915 end if;
916
917 Actual := First_Actual (N);
918 Formal := First_Formal_With_Extras (Subp);
919
920 while Present (Actual) loop
921 F_Type := Get_Fullest_View (Etype (Formal));
922 A_Type := Get_Fullest_View (Etype (Actual));
923
924 if Is_Array_Type (F_Type)
925 and then not Is_Constrained (F_Type)
926 and then Is_Constrained (A_Type)
927 then
928 Check_Static_Type (A_Type, Empty, DT);
929 end if;
930
931 Next_Actual (Actual);
932 Next_Formal_With_Extras (Formal);
933 end loop;
934 end;
935
936 -- An At_End_Proc in a statement sequence indicates that there
937 -- is a call from the enclosing construct or block to that
938 -- subprogram. As above, the called entity must be local and
939 -- not imported.
940
941 when N_Handled_Sequence_Of_Statements | N_Block_Statement =>
942 if Present (At_End_Proc (N))
943 and then Scope_Within (Entity (At_End_Proc (N)), Subp)
944 and then not Is_Imported (Entity (At_End_Proc (N)))
945 then
946 Append_Unique_Call
947 ((N, Current_Subprogram, Entity (At_End_Proc (N))));
948 end if;
949
950 -- Similarly, the following constructs include a semantic
951 -- attribute Procedure_To_Call that must be handled like
952 -- other calls. Likewise for attribute Storage_Pool.
953
954 when N_Allocator
955 | N_Extended_Return_Statement
956 | N_Free_Statement
957 | N_Simple_Return_Statement
958 =>
959 declare
960 Pool : constant Entity_Id := Storage_Pool (N);
961 Proc : constant Entity_Id := Procedure_To_Call (N);
962
963 begin
964 if Present (Proc)
965 and then Scope_Within (Proc, Subp)
966 and then not Is_Imported (Proc)
967 then
968 Append_Unique_Call ((N, Current_Subprogram, Proc));
969 end if;
970
971 if Present (Pool)
972 and then not Is_Library_Level_Entity (Pool)
973 and then Scope_Within_Or_Same (Scope (Pool), Subp)
974 then
975 Caller := Current_Subprogram;
976 Callee := Enclosing_Subprogram (Pool);
977
978 if Callee /= Caller then
979 Note_Uplevel_Ref (Pool, Empty, Caller, Callee);
980 end if;
981 end if;
982 end;
983
984 -- For an allocator with a qualified expression, check type
985 -- of expression being qualified. The explicit type name is
986 -- handled as an entity reference.
987
988 if Nkind (N) = N_Allocator
989 and then Nkind (Expression (N)) = N_Qualified_Expression
990 then
991 declare
992 DT : Boolean := False;
993 begin
994 Check_Static_Type
995 (Etype (Expression (Expression (N))), Empty, DT);
996 end;
997
998 -- For a Return or Free (all other nodes we handle here),
999 -- we usually need the size of the object, so we need to be
1000 -- sure that any nonstatic bounds of the expression's type
1001 -- that are uplevel are handled.
1002
1003 elsif Nkind (N) /= N_Allocator
1004 and then Present (Expression (N))
1005 then
1006 declare
1007 DT : Boolean := False;
1008 begin
1009 Check_Static_Type
1010 (Etype (Expression (N)),
1011 Empty,
1012 DT,
1013 Check_Designated => Nkind (N) = N_Free_Statement);
1014 end;
1015 end if;
1016
1017 -- A 'Access reference is a (potential) call. So is 'Address,
1018 -- in particular on imported subprograms. Other attributes
1019 -- require special handling.
1020
1021 when N_Attribute_Reference =>
1022 declare
1023 Attr : constant Attribute_Id :=
1024 Get_Attribute_Id (Attribute_Name (N));
1025 begin
1026 case Attr is
1027 when Attribute_Access
1028 | Attribute_Unchecked_Access
1029 | Attribute_Unrestricted_Access
1030 | Attribute_Address
1031 =>
1032 if Nkind (Prefix (N)) in N_Has_Entity then
1033 Ent := Entity (Prefix (N));
1034
1035 -- We only need to examine calls to subprograms
1036 -- nested within current Subp.
1037
1038 if Scope_Within (Ent, Subp) then
1039 if Is_Imported (Ent) then
1040 null;
1041
1042 elsif Is_Subprogram (Ent) then
1043 Append_Unique_Call
1044 ((N, Current_Subprogram, Ent));
1045 end if;
1046 end if;
1047 end if;
1048
1049 -- References to bounds can be uplevel references if
1050 -- the type isn't static.
1051
1052 when Attribute_First
1053 | Attribute_Last
1054 | Attribute_Length
1055 =>
1056 -- Special-case attributes of objects whose bounds
1057 -- may be uplevel references. More complex prefixes
1058 -- handled during full traversal. Note that if the
1059 -- nominal subtype of the prefix is unconstrained,
1060 -- the bound must be obtained from the object, not
1061 -- from the (possibly) uplevel reference. We call
1062 -- Get_Referenced_Object to deal with prefixes that
1063 -- are object renamings (prefixes that are types
1064 -- can be passed and will simply be returned). But
1065 -- it's also legal to get the bounds from the type
1066 -- of the prefix, so we have to handle both cases.
1067
1068 declare
1069 DT : Boolean := False;
1070
1071 begin
1072 if Is_Constrained
1073 (Etype (Get_Referenced_Object (Prefix (N))))
1074 then
1075 Check_Static_Type
1076 (Etype (Get_Referenced_Object (Prefix (N))),
1077 Empty, DT);
1078 end if;
1079
1080 if Is_Constrained (Etype (Prefix (N))) then
1081 Check_Static_Type
1082 (Etype (Prefix (N)), Empty, DT);
1083 end if;
1084 end;
1085
1086 when others =>
1087 null;
1088 end case;
1089 end;
1090
1091 -- Component associations in aggregates are either static or
1092 -- else the aggregate will be expanded into assignments, in
1093 -- which case the expression is analyzed later and provides
1094 -- no relevant code generation.
1095
1096 when N_Component_Association =>
1097 if No (Expression (N))
1098 or else No (Etype (Expression (N)))
1099 then
1100 return Skip;
1101 end if;
1102
1103 -- Generic associations are not analyzed: the actuals are
1104 -- transferred to renaming and subtype declarations that
1105 -- are the ones that must be examined.
1106
1107 when N_Generic_Association =>
1108 return Skip;
1109
1110 -- Indexed references can be uplevel if the type isn't static
1111 -- and if the lower bound (or an inner bound for a multi-
1112 -- dimensional array) is uplevel.
1113
1114 when N_Indexed_Component
1115 | N_Slice
1116 =>
1117 if Is_Constrained (Etype (Prefix (N))) then
1118 declare
1119 DT : Boolean := False;
1120 begin
1121 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1122 end;
1123 end if;
1124
1125 -- A selected component can have an implicit up-level
1126 -- reference due to the bounds of previous fields in the
1127 -- record. We simplify the processing here by examining
1128 -- all components of the record.
1129
1130 -- Selected components appear as unit names and end labels
1131 -- for child units. Prefixes of these nodes denote parent
1132 -- units and carry no type information so they are skipped.
1133
1134 when N_Selected_Component =>
1135 if Present (Etype (Prefix (N))) then
1136 declare
1137 DT : Boolean := False;
1138 begin
1139 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1140 end;
1141 end if;
1142
1143 -- For EQ/NE comparisons, we need the type of the operands
1144 -- in order to do the comparison, which means we need the
1145 -- bounds.
1146
1147 when N_Op_Eq
1148 | N_Op_Ne
1149 =>
1150 declare
1151 DT : Boolean := False;
1152 begin
1153 Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT);
1154 Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
1155 end;
1156
1157 -- Likewise we need the sizes to compute how much to move in
1158 -- an assignment.
1159
1160 when N_Assignment_Statement =>
1161 declare
1162 DT : Boolean := False;
1163 begin
1164 Check_Static_Type (Etype (Name (N)), Empty, DT);
1165 Check_Static_Type (Etype (Expression (N)), Empty, DT);
1166 end;
1167
1168 -- Record a subprogram. We record a subprogram body that acts
1169 -- as a spec. Otherwise we record a subprogram declaration,
1170 -- providing that it has a corresponding body we can get hold
1171 -- of. The case of no corresponding body being available is
1172 -- ignored for now.
1173
1174 when N_Subprogram_Body =>
1175 Ent := Unique_Defining_Entity (N);
1176
1177 -- Ignore generic subprogram
1178
1179 if Is_Generic_Subprogram (Ent) then
1180 return Skip;
1181 end if;
1182
1183 -- Make new entry in subprogram table if not already made
1184
1185 Register_Subprogram (Ent, N);
1186
1187 -- Record a call from an At_End_Proc
1188
1189 if Present (At_End_Proc (N))
1190 and then Scope_Within (Entity (At_End_Proc (N)), Subp)
1191 and then not Is_Imported (Entity (At_End_Proc (N)))
1192 then
1193 Append_Unique_Call ((N, Ent, Entity (At_End_Proc (N))));
1194 end if;
1195
1196 -- We make a recursive call to scan the subprogram body, so
1197 -- that we can save and restore Current_Subprogram.
1198
1199 declare
1200 Save_CS : constant Entity_Id := Current_Subprogram;
1201 Decl : Node_Id;
1202
1203 begin
1204 Current_Subprogram := Ent;
1205
1206 -- Scan declarations
1207
1208 Decl := First (Declarations (N));
1209 while Present (Decl) loop
1210 Visit (Decl);
1211 Next (Decl);
1212 end loop;
1213
1214 -- Scan statements
1215
1216 Visit (Handled_Statement_Sequence (N));
1217
1218 -- Restore current subprogram setting
1219
1220 Current_Subprogram := Save_CS;
1221 end;
1222
1223 -- Now at this level, return skipping the subprogram body
1224 -- descendants, since we already took care of them!
1225
1226 return Skip;
1227
1228 -- If we have a body stub, visit the associated subunit, which
1229 -- is a semantic descendant of the stub.
1230
1231 when N_Body_Stub =>
1232 Visit (Library_Unit (N));
1233
1234 -- A declaration of a wrapper package indicates a subprogram
1235 -- instance for which there is no explicit body. Enter the
1236 -- subprogram instance in the table.
1237
1238 when N_Package_Declaration =>
1239 if Is_Wrapper_Package (Defining_Entity (N)) then
1240 Register_Subprogram
1241 (Related_Instance (Defining_Entity (N)), Empty);
1242 end if;
1243
1244 -- Skip generic declarations
1245
1246 when N_Generic_Declaration =>
1247 return Skip;
1248
1249 -- Skip generic package body
1250
1251 when N_Package_Body =>
1252 if Present (Corresponding_Spec (N))
1253 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
1254 then
1255 return Skip;
1256 end if;
1257
1258 -- Aspects, pragmas and component declarations are ignored.
1259 -- Quantified expressions are expanded into explicit loops
1260 -- and the original epression must be ignored.
1261
1262 when N_Aspect_Specification
1263 | N_Component_Declaration
1264 | N_Pragma
1265 | N_Quantified_Expression
1266 =>
1267 return Skip;
1268
1269 -- We want to skip the function spec for a generic function
1270 -- to avoid looking at any generic types that might be in
1271 -- its formals.
1272
1273 when N_Function_Specification =>
1274 if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then
1275 return Skip;
1276 end if;
1277
1278 -- Otherwise record an uplevel reference in a local identifier
1279
1280 when others =>
1281 if Nkind (N) in N_Has_Entity
1282 and then Present (Entity (N))
1283 then
1284 Ent := Entity (N);
1285
1286 -- Only interested in entities declared within our nest
1287
1288 if not Is_Library_Level_Entity (Ent)
1289 and then Scope_Within_Or_Same (Scope (Ent), Subp)
1290
1291 -- Skip entities defined in inlined subprograms
1292
1293 and then
1294 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
1295
1296 -- Constants and variables are potentially uplevel
1297 -- references to global declarations.
1298
1299 and then
1300 (Ekind (Ent) in E_Constant
1301 | E_Loop_Parameter
1302 | E_Variable
1303
1304 -- Formals are interesting, but not if being used
1305 -- as mere names of parameters for name notation
1306 -- calls.
1307
1308 or else
1309 (Is_Formal (Ent)
1310 and then not
1311 (Nkind (Parent (N)) = N_Parameter_Association
1312 and then Selector_Name (Parent (N)) = N))
1313
1314 -- Types other than known Is_Static types are
1315 -- potentially interesting.
1316
1317 or else
1318 (Is_Type (Ent) and then not Is_Static_Type (Ent)))
1319 then
1320 -- Here we have a potentially interesting uplevel
1321 -- reference to examine.
1322
1323 if Is_Type (Ent) then
1324 declare
1325 DT : Boolean := False;
1326
1327 begin
1328 Check_Static_Type (Ent, N, DT);
1329 return OK;
1330 end;
1331 end if;
1332
1333 Caller := Current_Subprogram;
1334 Callee := Enclosing_Subprogram (Ent);
1335
1336 if Callee /= Caller
1337 and then (not Is_Static_Type (Ent)
1338 or else Needs_Fat_Pointer (Ent))
1339 then
1340 Note_Uplevel_Ref (Ent, N, Caller, Callee);
1341
1342 -- Check the type of a formal parameter of the current
1343 -- subprogram, whose formal type may be an uplevel
1344 -- reference.
1345
1346 elsif Is_Formal (Ent)
1347 and then Scope (Ent) = Current_Subprogram
1348 then
1349 declare
1350 DT : Boolean := False;
1351
1352 begin
1353 Check_Static_Type (Etype (Ent), Empty, DT);
1354 end;
1355 end if;
1356 end if;
1357 end if;
1358 end case;
1359
1360 -- Fall through to continue scanning children of this node
1361
1362 return OK;
1363 end Visit_Node;
1364
1365 -- Start of processing for Build_Tables
1366
1367 begin
1368 -- Traverse the body to get subprograms, calls and uplevel references
1369
1370 Visit (Subp_Body);
1371 end Build_Tables;
1372
1373 -- Now do the first transitive closure which determines which
1374 -- subprograms in the nest are actually reachable.
1375
1376 Reachable_Closure : declare
1377 Modified : Boolean;
1378
1379 begin
1380 Subps.Table (Subps_First).Reachable := True;
1381
1382 -- We use a simple minded algorithm as follows (obviously this can
1383 -- be done more efficiently, using one of the standard algorithms
1384 -- for efficient transitive closure computation, but this is simple
1385 -- and most likely fast enough that its speed does not matter).
1386
1387 -- Repeatedly scan the list of calls. Any time we find a call from
1388 -- A to B, where A is reachable, but B is not, then B is reachable,
1389 -- and note that we have made a change by setting Modified True. We
1390 -- repeat this until we make a pass with no modifications.
1391
1392 Outer : loop
1393 Modified := False;
1394 Inner : for J in Calls.First .. Calls.Last loop
1395 declare
1396 CTJ : Call_Entry renames Calls.Table (J);
1397
1398 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1399 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1400
1401 SUBF : Subp_Entry renames Subps.Table (SINF);
1402 SUBT : Subp_Entry renames Subps.Table (SINT);
1403
1404 begin
1405 if SUBF.Reachable and then not SUBT.Reachable then
1406 SUBT.Reachable := True;
1407 Modified := True;
1408 end if;
1409 end;
1410 end loop Inner;
1411
1412 exit Outer when not Modified;
1413 end loop Outer;
1414 end Reachable_Closure;
1415
1416 -- Remove calls from unreachable subprograms
1417
1418 declare
1419 New_Index : Nat;
1420
1421 begin
1422 New_Index := 0;
1423 for J in Calls.First .. Calls.Last loop
1424 declare
1425 CTJ : Call_Entry renames Calls.Table (J);
1426
1427 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1428 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1429
1430 SUBF : Subp_Entry renames Subps.Table (SINF);
1431 SUBT : Subp_Entry renames Subps.Table (SINT);
1432
1433 begin
1434 if SUBF.Reachable then
1435 pragma Assert (SUBT.Reachable);
1436 New_Index := New_Index + 1;
1437 Calls.Table (New_Index) := Calls.Table (J);
1438 end if;
1439 end;
1440 end loop;
1441
1442 Calls.Set_Last (New_Index);
1443 end;
1444
1445 -- Remove uplevel references from unreachable subprograms
1446
1447 declare
1448 New_Index : Nat;
1449
1450 begin
1451 New_Index := 0;
1452 for J in Urefs.First .. Urefs.Last loop
1453 declare
1454 URJ : Uref_Entry renames Urefs.Table (J);
1455
1456 SINF : constant SI_Type := Subp_Index (URJ.Caller);
1457 SINT : constant SI_Type := Subp_Index (URJ.Callee);
1458
1459 SUBF : Subp_Entry renames Subps.Table (SINF);
1460 SUBT : Subp_Entry renames Subps.Table (SINT);
1461
1462 S : Entity_Id;
1463
1464 begin
1465 -- Keep reachable reference
1466
1467 if SUBF.Reachable then
1468 New_Index := New_Index + 1;
1469 Urefs.Table (New_Index) := Urefs.Table (J);
1470
1471 -- And since we know we are keeping this one, this is a good
1472 -- place to fill in information for a good reference.
1473
1474 -- Mark all enclosing subprograms need to declare AREC
1475
1476 S := URJ.Caller;
1477 loop
1478 S := Enclosing_Subprogram (S);
1479
1480 -- If we are at the top level, as can happen with
1481 -- references to formals in aspects of nested subprogram
1482 -- declarations, there are no further subprograms to mark
1483 -- as requiring activation records.
1484
1485 exit when No (S);
1486
1487 declare
1488 SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
1489 begin
1490 SUBI.Declares_AREC := True;
1491
1492 -- If this entity was marked reachable because it is
1493 -- in a task or protected type, there may not appear
1494 -- to be any calls to it, which would normally adjust
1495 -- the levels of the parent subprograms. So we need to
1496 -- be sure that the uplevel reference of that entity
1497 -- takes into account possible calls.
1498
1499 if In_Synchronized_Unit (SUBF.Ent)
1500 and then SUBT.Lev < SUBI.Uplevel_Ref
1501 then
1502 SUBI.Uplevel_Ref := SUBT.Lev;
1503 end if;
1504 end;
1505
1506 exit when S = URJ.Callee;
1507 end loop;
1508
1509 -- Add to list of uplevel referenced entities for Callee.
1510 -- We do not add types to this list, only actual references
1511 -- to objects that will be referenced uplevel, and we use
1512 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1513 -- duplicate entries in the list. Discriminants are also
1514 -- excluded, only the enclosing object can appear in the
1515 -- list.
1516
1517 if not Is_Uplevel_Referenced_Entity (URJ.Ent)
1518 and then Ekind (URJ.Ent) /= E_Discriminant
1519 then
1520 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
1521 Append_New_Elmt (URJ.Ent, SUBT.Uents);
1522 end if;
1523
1524 -- And set uplevel indication for caller
1525
1526 if SUBT.Lev < SUBF.Uplevel_Ref then
1527 SUBF.Uplevel_Ref := SUBT.Lev;
1528 end if;
1529 end if;
1530 end;
1531 end loop;
1532
1533 Urefs.Set_Last (New_Index);
1534 end;
1535
1536 -- Remove unreachable subprograms from Subps table. Note that we do
1537 -- this after eliminating entries from the other two tables, since
1538 -- those elimination steps depend on referencing the Subps table.
1539
1540 declare
1541 New_SI : SI_Type;
1542
1543 begin
1544 New_SI := Subps_First - 1;
1545 for J in Subps_First .. Subps.Last loop
1546 declare
1547 STJ : Subp_Entry renames Subps.Table (J);
1548 Spec : Node_Id;
1549 Decl : Node_Id;
1550
1551 begin
1552 -- Subprogram is reachable, copy and reset index
1553
1554 if STJ.Reachable then
1555 New_SI := New_SI + 1;
1556 Subps.Table (New_SI) := STJ;
1557 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
1558
1559 -- Subprogram is not reachable
1560
1561 else
1562 -- Clear index, since no longer active
1563
1564 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
1565
1566 -- Output debug information if -gnatd.3 set
1567
1568 if Debug_Flag_Dot_3 then
1569 Write_Str ("Eliminate ");
1570 Write_Name (Chars (Subps.Table (J).Ent));
1571 Write_Str (" at ");
1572 Write_Location (Sloc (Subps.Table (J).Ent));
1573 Write_Str (" (not referenced)");
1574 Write_Eol;
1575 end if;
1576
1577 -- Rewrite declaration, body, and corresponding freeze node
1578 -- to null statements.
1579
1580 -- A subprogram instantiation does not have an explicit
1581 -- body. If unused, we could remove the corresponding
1582 -- wrapper package and its body.
1583
1584 if Present (STJ.Bod) then
1585 Spec := Corresponding_Spec (STJ.Bod);
1586
1587 if Present (Spec) then
1588 Decl := Parent (Declaration_Node (Spec));
1589 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
1590
1591 if Present (Freeze_Node (Spec)) then
1592 Rewrite (Freeze_Node (Spec),
1593 Make_Null_Statement (Sloc (Decl)));
1594 end if;
1595 end if;
1596
1597 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
1598 end if;
1599 end if;
1600 end;
1601 end loop;
1602
1603 Subps.Set_Last (New_SI);
1604 end;
1605
1606 -- Now it is time for the second transitive closure, which follows calls
1607 -- and makes sure that A calls B, and B has uplevel references, then A
1608 -- is also marked as having uplevel references.
1609
1610 Closure_Uplevel : declare
1611 Modified : Boolean;
1612
1613 begin
1614 -- We use a simple minded algorithm as follows (obviously this can
1615 -- be done more efficiently, using one of the standard algorithms
1616 -- for efficient transitive closure computation, but this is simple
1617 -- and most likely fast enough that its speed does not matter).
1618
1619 -- Repeatedly scan the list of calls. Any time we find a call from
1620 -- A to B, where B has uplevel references, make sure that A is marked
1621 -- as having at least the same level of uplevel referencing.
1622
1623 Outer2 : loop
1624 Modified := False;
1625 Inner2 : for J in Calls.First .. Calls.Last loop
1626 declare
1627 CTJ : Call_Entry renames Calls.Table (J);
1628 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1629 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1630 SUBF : Subp_Entry renames Subps.Table (SINF);
1631 SUBT : Subp_Entry renames Subps.Table (SINT);
1632 begin
1633 if SUBT.Lev > SUBT.Uplevel_Ref
1634 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
1635 then
1636 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
1637 Modified := True;
1638 end if;
1639 end;
1640 end loop Inner2;
1641
1642 exit Outer2 when not Modified;
1643 end loop Outer2;
1644 end Closure_Uplevel;
1645
1646 -- We have one more step before the tables are complete. An uplevel
1647 -- call from subprogram A to subprogram B where subprogram B has uplevel
1648 -- references is in effect an uplevel reference, and must arrange for
1649 -- the proper activation link to be passed.
1650
1651 for J in Calls.First .. Calls.Last loop
1652 declare
1653 CTJ : Call_Entry renames Calls.Table (J);
1654
1655 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1656 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1657
1658 SUBF : Subp_Entry renames Subps.Table (SINF);
1659 SUBT : Subp_Entry renames Subps.Table (SINT);
1660
1661 A : Entity_Id;
1662
1663 begin
1664 -- If callee has uplevel references
1665
1666 if SUBT.Uplevel_Ref < SUBT.Lev
1667
1668 -- And this is an uplevel call
1669
1670 and then SUBT.Lev < SUBF.Lev
1671 then
1672 -- We need to arrange for finding the uplink
1673
1674 A := CTJ.Caller;
1675 loop
1676 A := Enclosing_Subprogram (A);
1677 Subps.Table (Subp_Index (A)).Declares_AREC := True;
1678 exit when A = CTJ.Callee;
1679
1680 -- In any case exit when we get to the outer level. This
1681 -- happens in some odd cases with generics (in particular
1682 -- sem_ch3.adb does not compile without this kludge ???).
1683
1684 exit when A = Subp;
1685 end loop;
1686 end if;
1687 end;
1688 end loop;
1689
1690 -- The tables are now complete, so we can record the last index in the
1691 -- Subps table for later reference in Cprint.
1692
1693 Subps.Table (Subps_First).Last := Subps.Last;
1694
1695 -- Next step, create the entities for code we will insert. We do this
1696 -- at the start so that all the entities are defined, regardless of the
1697 -- order in which we do the code insertions.
1698
1699 Create_Entities : for J in Subps_First .. Subps.Last loop
1700 declare
1701 STJ : Subp_Entry renames Subps.Table (J);
1702 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1703
1704 begin
1705 -- First we create the ARECnF entity for the additional formal for
1706 -- all subprograms which need an activation record passed.
1707
1708 if STJ.Uplevel_Ref < STJ.Lev then
1709 STJ.ARECnF :=
1710 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
1711 end if;
1712
1713 -- Define the AREC entities for the activation record if needed
1714
1715 if STJ.Declares_AREC then
1716 STJ.ARECn :=
1717 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
1718 STJ.ARECnT :=
1719 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
1720 STJ.ARECnPT :=
1721 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
1722 STJ.ARECnP :=
1723 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
1724
1725 -- Define uplink component entity if inner nesting case
1726
1727 if Present (STJ.ARECnF) then
1728 STJ.ARECnU :=
1729 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1730 end if;
1731 end if;
1732 end;
1733 end loop Create_Entities;
1734
1735 -- Loop through subprograms
1736
1737 Subp_Loop : declare
1738 Addr : Entity_Id := Empty;
1739
1740 begin
1741 for J in Subps_First .. Subps.Last loop
1742 declare
1743 STJ : Subp_Entry renames Subps.Table (J);
1744
1745 begin
1746 -- First add the extra formal if needed. This applies to all
1747 -- nested subprograms that require an activation record to be
1748 -- passed, as indicated by ARECnF being defined.
1749
1750 if Present (STJ.ARECnF) then
1751
1752 -- Here we need the extra formal. We do the expansion and
1753 -- analysis of this manually, since it is fairly simple,
1754 -- and it is not obvious how we can get what we want if we
1755 -- try to use the normal Analyze circuit.
1756
1757 Add_Extra_Formal : declare
1758 Encl : constant SI_Type := Enclosing_Subp (J);
1759 STJE : Subp_Entry renames Subps.Table (Encl);
1760 -- Index and Subp_Entry for enclosing routine
1761
1762 Form : constant Entity_Id := STJ.ARECnF;
1763 -- The formal to be added. Note that n here is one less
1764 -- than the level of the subprogram itself (STJ.Ent).
1765
1766 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1767 -- S is an N_Function/Procedure_Specification node, and F
1768 -- is the new entity to add to this subprogram spec as
1769 -- the last Extra_Formal.
1770
1771 ----------------------
1772 -- Add_Form_To_Spec --
1773 ----------------------
1774
1775 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1776 Sub : constant Entity_Id := Defining_Entity (S);
1777 Ent : Entity_Id;
1778
1779 begin
1780 -- Case of at least one Extra_Formal is present, set
1781 -- ARECnF as the new last entry in the list.
1782
1783 if Present (Extra_Formals (Sub)) then
1784 Ent := Extra_Formals (Sub);
1785 while Present (Extra_Formal (Ent)) loop
1786 Ent := Extra_Formal (Ent);
1787 end loop;
1788
1789 Set_Extra_Formal (Ent, F);
1790
1791 -- No Extra formals present
1792
1793 else
1794 Set_Extra_Formals (Sub, F);
1795 Ent := Last_Formal (Sub);
1796
1797 if Present (Ent) then
1798 Set_Extra_Formal (Ent, F);
1799 end if;
1800 end if;
1801 end Add_Form_To_Spec;
1802
1803 -- Start of processing for Add_Extra_Formal
1804
1805 begin
1806 -- Decorate the new formal entity
1807
1808 Set_Scope (Form, STJ.Ent);
1809 Mutate_Ekind (Form, E_In_Parameter);
1810 Set_Etype (Form, STJE.ARECnPT);
1811 Set_Mechanism (Form, By_Copy);
1812 Set_Never_Set_In_Source (Form, True);
1813 Set_Analyzed (Form, True);
1814 Set_Comes_From_Source (Form, False);
1815 Set_Is_Activation_Record (Form, True);
1816
1817 -- Case of only body present
1818
1819 if Acts_As_Spec (STJ.Bod) then
1820 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1821
1822 -- Case of separate spec
1823
1824 else
1825 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1826 end if;
1827 end Add_Extra_Formal;
1828 end if;
1829
1830 -- Processing for subprograms that declare an activation record
1831
1832 if Present (STJ.ARECn) then
1833
1834 -- Local declarations for one such subprogram
1835
1836 declare
1837 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1838
1839 Decls : constant List_Id := New_List;
1840 -- List of new declarations we create
1841
1842 Clist : List_Id;
1843 Comp : Entity_Id;
1844
1845 Decl_Assign : Node_Id;
1846 -- Assignment to set uplink, Empty if none
1847
1848 Decl_ARECnT : Node_Id;
1849 Decl_ARECnPT : Node_Id;
1850 Decl_ARECn : Node_Id;
1851 Decl_ARECnP : Node_Id;
1852 -- Declaration nodes for the AREC entities we build
1853
1854 begin
1855 -- Build list of component declarations for ARECnT and
1856 -- load System.Address.
1857
1858 Clist := Empty_List;
1859
1860 if No (Addr) then
1861 Addr := RTE (RE_Address);
1862 end if;
1863
1864 -- If we are in a subprogram that has a static link that
1865 -- is passed in (as indicated by ARECnF being defined),
1866 -- then include ARECnU : ARECmPT where ARECmPT comes from
1867 -- the level one higher than the current level, and the
1868 -- entity ARECnPT comes from the enclosing subprogram.
1869
1870 if Present (STJ.ARECnF) then
1871 declare
1872 STJE : Subp_Entry
1873 renames Subps.Table (Enclosing_Subp (J));
1874 begin
1875 Append_To (Clist,
1876 Make_Component_Declaration (Loc,
1877 Defining_Identifier => STJ.ARECnU,
1878 Component_Definition =>
1879 Make_Component_Definition (Loc,
1880 Subtype_Indication =>
1881 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1882 end;
1883 end if;
1884
1885 -- Add components for uplevel referenced entities
1886
1887 if Present (STJ.Uents) then
1888 declare
1889 Elmt : Elmt_Id;
1890 Ptr_Decl : Node_Id;
1891 Uent : Entity_Id;
1892
1893 Indx : Nat;
1894 -- 1's origin of index in list of elements. This is
1895 -- used to uniquify names if needed in Upref_Name.
1896
1897 begin
1898 Elmt := First_Elmt (STJ.Uents);
1899 Indx := 0;
1900 while Present (Elmt) loop
1901 Uent := Node (Elmt);
1902 Indx := Indx + 1;
1903
1904 Comp :=
1905 Make_Defining_Identifier (Loc,
1906 Chars => Upref_Name (Uent, Indx, Clist));
1907
1908 Set_Activation_Record_Component
1909 (Uent, Comp);
1910
1911 if Needs_Fat_Pointer (Uent) then
1912
1913 -- Build corresponding access type
1914
1915 Ptr_Decl :=
1916 Build_Access_Type_Decl
1917 (Etype (Uent), STJ.Ent);
1918 Append_To (Decls, Ptr_Decl);
1919
1920 -- And use its type in the corresponding
1921 -- component.
1922
1923 Append_To (Clist,
1924 Make_Component_Declaration (Loc,
1925 Defining_Identifier => Comp,
1926 Component_Definition =>
1927 Make_Component_Definition (Loc,
1928 Subtype_Indication =>
1929 New_Occurrence_Of
1930 (Defining_Identifier (Ptr_Decl),
1931 Loc))));
1932 else
1933 Append_To (Clist,
1934 Make_Component_Declaration (Loc,
1935 Defining_Identifier => Comp,
1936 Component_Definition =>
1937 Make_Component_Definition (Loc,
1938 Subtype_Indication =>
1939 New_Occurrence_Of (Addr, Loc))));
1940 end if;
1941 Next_Elmt (Elmt);
1942 end loop;
1943 end;
1944 end if;
1945
1946 -- Now we can insert the AREC declarations into the body
1947 -- type ARECnT is record .. end record;
1948 -- pragma Suppress_Initialization (ARECnT);
1949
1950 -- Note that we need to set the Suppress_Initialization
1951 -- flag after Decl_ARECnT has been analyzed.
1952
1953 Decl_ARECnT :=
1954 Make_Full_Type_Declaration (Loc,
1955 Defining_Identifier => STJ.ARECnT,
1956 Type_Definition =>
1957 Make_Record_Definition (Loc,
1958 Component_List =>
1959 Make_Component_List (Loc,
1960 Component_Items => Clist)));
1961 Append_To (Decls, Decl_ARECnT);
1962
1963 -- type ARECnPT is access all ARECnT;
1964
1965 Decl_ARECnPT :=
1966 Make_Full_Type_Declaration (Loc,
1967 Defining_Identifier => STJ.ARECnPT,
1968 Type_Definition =>
1969 Make_Access_To_Object_Definition (Loc,
1970 All_Present => True,
1971 Subtype_Indication =>
1972 New_Occurrence_Of (STJ.ARECnT, Loc)));
1973 Append_To (Decls, Decl_ARECnPT);
1974
1975 -- ARECn : aliased ARECnT;
1976
1977 Decl_ARECn :=
1978 Make_Object_Declaration (Loc,
1979 Defining_Identifier => STJ.ARECn,
1980 Aliased_Present => True,
1981 Object_Definition =>
1982 New_Occurrence_Of (STJ.ARECnT, Loc));
1983 Append_To (Decls, Decl_ARECn);
1984
1985 -- ARECnP : constant ARECnPT := ARECn'Access;
1986
1987 Decl_ARECnP :=
1988 Make_Object_Declaration (Loc,
1989 Defining_Identifier => STJ.ARECnP,
1990 Constant_Present => True,
1991 Object_Definition =>
1992 New_Occurrence_Of (STJ.ARECnPT, Loc),
1993 Expression =>
1994 Make_Attribute_Reference (Loc,
1995 Prefix =>
1996 New_Occurrence_Of (STJ.ARECn, Loc),
1997 Attribute_Name => Name_Access));
1998 Append_To (Decls, Decl_ARECnP);
1999
2000 -- If we are in a subprogram that has a static link that
2001 -- is passed in (as indicated by ARECnF being defined),
2002 -- then generate ARECn.ARECmU := ARECmF where m is
2003 -- one less than the current level to set the uplink.
2004
2005 if Present (STJ.ARECnF) then
2006 Decl_Assign :=
2007 Make_Assignment_Statement (Loc,
2008 Name =>
2009 Make_Selected_Component (Loc,
2010 Prefix =>
2011 New_Occurrence_Of (STJ.ARECn, Loc),
2012 Selector_Name =>
2013 New_Occurrence_Of (STJ.ARECnU, Loc)),
2014 Expression =>
2015 New_Occurrence_Of (STJ.ARECnF, Loc));
2016 Append_To (Decls, Decl_Assign);
2017
2018 else
2019 Decl_Assign := Empty;
2020 end if;
2021
2022 if No (Declarations (STJ.Bod)) then
2023 Set_Declarations (STJ.Bod, Decls);
2024 else
2025 Prepend_List_To (Declarations (STJ.Bod), Decls);
2026 end if;
2027
2028 -- Analyze the newly inserted declarations. Note that we
2029 -- do not need to establish the whole scope stack, since
2030 -- we have already set all entity fields (so there will
2031 -- be no searching of upper scopes to resolve names). But
2032 -- we do set the scope of the current subprogram, so that
2033 -- newly created entities go in the right entity chain.
2034
2035 -- We analyze with all checks suppressed (since we do
2036 -- not expect any exceptions).
2037
2038 Push_Scope (STJ.Ent);
2039 Analyze (Decl_ARECnT, Suppress => All_Checks);
2040
2041 -- Note that we need to call Set_Suppress_Initialization
2042 -- after Decl_ARECnT has been analyzed, but before
2043 -- analyzing Decl_ARECnP so that the flag is properly
2044 -- taking into account.
2045
2046 Set_Suppress_Initialization (STJ.ARECnT);
2047
2048 Analyze (Decl_ARECnPT, Suppress => All_Checks);
2049 Analyze (Decl_ARECn, Suppress => All_Checks);
2050 Analyze (Decl_ARECnP, Suppress => All_Checks);
2051
2052 if Present (Decl_Assign) then
2053 Analyze (Decl_Assign, Suppress => All_Checks);
2054 end if;
2055
2056 Pop_Scope;
2057
2058 -- Next step, for each uplevel referenced entity, add
2059 -- assignment operations to set the component in the
2060 -- activation record.
2061
2062 if Present (STJ.Uents) then
2063 declare
2064 Elmt : Elmt_Id;
2065
2066 begin
2067 Elmt := First_Elmt (STJ.Uents);
2068 while Present (Elmt) loop
2069 declare
2070 Ent : constant Entity_Id := Node (Elmt);
2071 Loc : constant Source_Ptr := Sloc (Ent);
2072 Dec : constant Node_Id :=
2073 Declaration_Node (Ent);
2074
2075 Asn : Node_Id;
2076 Attr : Name_Id;
2077 Comp : Entity_Id;
2078 Ins : Node_Id;
2079 Rhs : Node_Id;
2080
2081 begin
2082 -- For parameters, we insert the assignment
2083 -- right after the declaration of ARECnP.
2084 -- For all other entities, we insert the
2085 -- assignment immediately after the
2086 -- declaration of the entity or after the
2087 -- freeze node if present.
2088
2089 -- Note: we don't need to mark the entity
2090 -- as being aliased, because the address
2091 -- attribute will mark it as Address_Taken,
2092 -- and that is good enough.
2093
2094 if Is_Formal (Ent) then
2095 Ins := Decl_ARECnP;
2096
2097 elsif Has_Delayed_Freeze (Ent) then
2098 Ins := Freeze_Node (Ent);
2099
2100 else
2101 Ins := Dec;
2102 end if;
2103
2104 -- Build and insert the assignment:
2105 -- ARECn.nam := nam'Address
2106 -- or else 'Unchecked_Access for
2107 -- unconstrained array.
2108
2109 if Needs_Fat_Pointer (Ent) then
2110 Attr := Name_Unchecked_Access;
2111 else
2112 Attr := Name_Address;
2113 end if;
2114
2115 Rhs :=
2116 Make_Attribute_Reference (Loc,
2117 Prefix =>
2118 New_Occurrence_Of (Ent, Loc),
2119 Attribute_Name => Attr);
2120
2121 -- If the entity is an unconstrained formal
2122 -- we wrap the attribute reference in an
2123 -- unchecked conversion to the type of the
2124 -- activation record component, to prevent
2125 -- spurious subtype conformance errors within
2126 -- instances.
2127
2128 if Is_Formal (Ent)
2129 and then not Is_Constrained (Etype (Ent))
2130 then
2131 -- Find target component and its type
2132
2133 Comp := First_Component (STJ.ARECnT);
2134 while Chars (Comp) /= Chars (Ent) loop
2135 Next_Component (Comp);
2136 end loop;
2137
2138 Rhs :=
2139 Unchecked_Convert_To (Etype (Comp), Rhs);
2140 end if;
2141
2142 Asn :=
2143 Make_Assignment_Statement (Loc,
2144 Name =>
2145 Make_Selected_Component (Loc,
2146 Prefix =>
2147 New_Occurrence_Of (STJ.ARECn, Loc),
2148 Selector_Name =>
2149 New_Occurrence_Of
2150 (Activation_Record_Component
2151 (Ent),
2152 Loc)),
2153 Expression => Rhs);
2154
2155 -- If we have a loop parameter, we have
2156 -- to insert before the first statement
2157 -- of the loop. Ins points to the
2158 -- N_Loop_Parameter_Specification or to
2159 -- an N_Iterator_Specification.
2160
2161 if Nkind (Ins) in
2162 N_Iterator_Specification |
2163 N_Loop_Parameter_Specification
2164 then
2165 -- Quantified expression are rewritten as
2166 -- loops during expansion.
2167
2168 if Nkind (Parent (Ins)) =
2169 N_Quantified_Expression
2170 then
2171 null;
2172
2173 else
2174 Ins :=
2175 First
2176 (Statements
2177 (Parent (Parent (Ins))));
2178 Insert_Before (Ins, Asn);
2179 end if;
2180
2181 else
2182 Insert_After (Ins, Asn);
2183 end if;
2184
2185 -- Analyze the assignment statement. We do
2186 -- not need to establish the relevant scope
2187 -- stack entries here, because we have
2188 -- already set the correct entity references,
2189 -- so no name resolution is required, and no
2190 -- new entities are created, so we don't even
2191 -- need to set the current scope.
2192
2193 -- We analyze with all checks suppressed
2194 -- (since we do not expect any exceptions).
2195
2196 Analyze (Asn, Suppress => All_Checks);
2197 end;
2198
2199 Next_Elmt (Elmt);
2200 end loop;
2201 end;
2202 end if;
2203 end;
2204 end if;
2205 end;
2206 end loop;
2207 end Subp_Loop;
2208
2209 -- Next step, process uplevel references. This has to be done in a
2210 -- separate pass, after completing the processing in Sub_Loop because we
2211 -- need all the AREC declarations generated, inserted, and analyzed so
2212 -- that the uplevel references can be successfully analyzed.
2213
2214 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
2215 declare
2216 UPJ : Uref_Entry renames Urefs.Table (J);
2217
2218 begin
2219 -- Ignore type references, these are implicit references that do
2220 -- not need rewriting (e.g. the appearance in a conversion).
2221 -- Also ignore if no reference was specified or if the rewriting
2222 -- has already been done (this can happen if the N_Identifier
2223 -- occurs more than one time in the tree). Also ignore references
2224 -- when not generating C code (in particular for the case of LLVM,
2225 -- since GNAT-LLVM will handle the processing for up-level refs).
2226
2227 if No (UPJ.Ref)
2228 or else not Is_Entity_Name (UPJ.Ref)
2229 or else No (Entity (UPJ.Ref))
2230 or else not Opt.Generate_C_Code
2231 then
2232 goto Continue;
2233 end if;
2234
2235 -- Rewrite one reference
2236
2237 Rewrite_One_Ref : declare
2238 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
2239 -- Source location for the reference
2240
2241 Typ : constant Entity_Id := Etype (UPJ.Ent);
2242 -- The type of the referenced entity
2243
2244 Atyp : Entity_Id;
2245 -- The actual subtype of the reference
2246
2247 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
2248 -- Subp_Index for caller containing reference
2249
2250 STJR : Subp_Entry renames Subps.Table (RS_Caller);
2251 -- Subp_Entry for subprogram containing reference
2252
2253 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
2254 -- Subp_Index for subprogram containing referenced entity
2255
2256 STJE : Subp_Entry renames Subps.Table (RS_Callee);
2257 -- Subp_Entry for subprogram containing referenced entity
2258
2259 Pfx : Node_Id;
2260 Comp : Entity_Id;
2261 SI : SI_Type;
2262
2263 begin
2264 Atyp := Etype (UPJ.Ref);
2265
2266 if Ekind (Atyp) /= E_Record_Subtype then
2267 Atyp := Get_Actual_Subtype (UPJ.Ref);
2268 end if;
2269
2270 -- Ignore if no ARECnF entity for enclosing subprogram which
2271 -- probably happens as a result of not properly treating
2272 -- instance bodies. To be examined ???
2273
2274 -- If this test is omitted, then the compilation of freeze.adb
2275 -- and inline.adb fail in unnesting mode.
2276
2277 if No (STJR.ARECnF) then
2278 goto Continue;
2279 end if;
2280
2281 -- If this is a reference to a global constant, use its value
2282 -- rather than create a reference. It is more efficient and
2283 -- furthermore indispensable if the context requires a
2284 -- constant, such as a branch of a case statement.
2285
2286 if Ekind (UPJ.Ent) = E_Constant
2287 and then Is_True_Constant (UPJ.Ent)
2288 and then Present (Constant_Value (UPJ.Ent))
2289 and then Is_Static_Expression (Constant_Value (UPJ.Ent))
2290 then
2291 Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent)));
2292 goto Continue;
2293 end if;
2294
2295 -- Push the current scope, so that the pointer type Tnn, and
2296 -- any subsidiary entities resulting from the analysis of the
2297 -- rewritten reference, go in the right entity chain.
2298
2299 Push_Scope (STJR.Ent);
2300
2301 -- Now we need to rewrite the reference. We have a reference
2302 -- from level STJR.Lev to level STJE.Lev. The general form of
2303 -- the rewritten reference for entity X is:
2304
2305 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
2306
2307 -- where a,b,c,d .. m =
2308 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
2309
2310 pragma Assert (STJR.Lev > STJE.Lev);
2311
2312 -- Compute the prefix of X. Here are examples to make things
2313 -- clear (with parens to show groupings, the prefix is
2314 -- everything except the .X at the end).
2315
2316 -- level 2 to level 1
2317
2318 -- AREC1F.X
2319
2320 -- level 3 to level 1
2321
2322 -- (AREC2F.AREC1U).X
2323
2324 -- level 4 to level 1
2325
2326 -- ((AREC3F.AREC2U).AREC1U).X
2327
2328 -- level 6 to level 2
2329
2330 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
2331
2332 -- In the above, ARECnF and ARECnU are pointers, so there are
2333 -- explicit dereferences required for these occurrences.
2334
2335 Pfx :=
2336 Make_Explicit_Dereference (Loc,
2337 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
2338 SI := RS_Caller;
2339 for L in STJE.Lev .. STJR.Lev - 2 loop
2340 SI := Enclosing_Subp (SI);
2341 Pfx :=
2342 Make_Explicit_Dereference (Loc,
2343 Prefix =>
2344 Make_Selected_Component (Loc,
2345 Prefix => Pfx,
2346 Selector_Name =>
2347 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
2348 end loop;
2349
2350 -- Get activation record component (must exist)
2351
2352 Comp := Activation_Record_Component (UPJ.Ent);
2353 pragma Assert (Present (Comp));
2354
2355 -- Do the replacement. If the component type is an access type,
2356 -- this is an uplevel reference for an entity that requires a
2357 -- fat pointer, so dereference the component.
2358
2359 if Is_Access_Type (Etype (Comp)) then
2360 Rewrite (UPJ.Ref,
2361 Make_Explicit_Dereference (Loc,
2362 Prefix =>
2363 Make_Selected_Component (Loc,
2364 Prefix => Pfx,
2365 Selector_Name =>
2366 New_Occurrence_Of (Comp, Loc))));
2367
2368 else
2369 Rewrite (UPJ.Ref,
2370 Make_Attribute_Reference (Loc,
2371 Prefix => New_Occurrence_Of (Atyp, Loc),
2372 Attribute_Name => Name_Deref,
2373 Expressions => New_List (
2374 Make_Selected_Component (Loc,
2375 Prefix => Pfx,
2376 Selector_Name =>
2377 New_Occurrence_Of (Comp, Loc)))));
2378 end if;
2379
2380 -- Analyze and resolve the new expression. We do not need to
2381 -- establish the relevant scope stack entries here, because we
2382 -- have already set all the correct entity references, so no
2383 -- name resolution is needed. We have already set the current
2384 -- scope, so that any new entities created will be in the right
2385 -- scope.
2386
2387 -- We analyze with all checks suppressed (since we do not
2388 -- expect any exceptions)
2389
2390 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
2391
2392 -- Generate an extra temporary to facilitate the C backend
2393 -- processing this dereference
2394
2395 if Opt.Modify_Tree_For_C
2396 and then Nkind (Parent (UPJ.Ref)) in
2397 N_Type_Conversion | N_Unchecked_Type_Conversion
2398 then
2399 Force_Evaluation (UPJ.Ref, Mode => Strict);
2400 end if;
2401
2402 Pop_Scope;
2403 end Rewrite_One_Ref;
2404 end;
2405
2406 <<Continue>>
2407 null;
2408 end loop Uplev_Refs;
2409
2410 -- Finally, loop through all calls adding extra actual for the
2411 -- activation record where it is required.
2412
2413 Adjust_Calls : for J in Calls.First .. Calls.Last loop
2414
2415 -- Process a single call, we are only interested in a call to a
2416 -- subprogram that actually needs a pointer to an activation record,
2417 -- as indicated by the ARECnF entity being set. This excludes the
2418 -- top level subprogram, and any subprogram not having uplevel refs.
2419
2420 Adjust_One_Call : declare
2421 CTJ : Call_Entry renames Calls.Table (J);
2422 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
2423 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
2424
2425 Loc : constant Source_Ptr := Sloc (CTJ.N);
2426
2427 Extra : Node_Id;
2428 ExtraP : Node_Id;
2429 SubX : SI_Type;
2430 Act : Node_Id;
2431
2432 begin
2433 if Present (STT.ARECnF)
2434 and then Nkind (CTJ.N) in N_Subprogram_Call
2435 then
2436 -- CTJ.N is a call to a subprogram which may require a pointer
2437 -- to an activation record. The subprogram containing the call
2438 -- is CTJ.From and the subprogram being called is CTJ.To, so we
2439 -- have a call from level STF.Lev to level STT.Lev.
2440
2441 -- There are three possibilities:
2442
2443 -- For a call to the same level, we just pass the activation
2444 -- record passed to the calling subprogram.
2445
2446 if STF.Lev = STT.Lev then
2447 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2448
2449 -- For a call that goes down a level, we pass a pointer to the
2450 -- activation record constructed within the caller (which may
2451 -- be the outer-level subprogram, but also may be a more deeply
2452 -- nested caller).
2453
2454 elsif STT.Lev = STF.Lev + 1 then
2455 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
2456
2457 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
2458 -- since it is not possible to do a downcall of more than
2459 -- one level.
2460
2461 -- For a call from level STF.Lev to level STT.Lev, we
2462 -- have to find the activation record needed by the
2463 -- callee. This is as follows:
2464
2465 -- ARECaF.ARECbU.ARECcU....ARECmU
2466
2467 -- where a,b,c .. m =
2468 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
2469
2470 else
2471 pragma Assert (STT.Lev < STF.Lev);
2472
2473 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2474 SubX := Subp_Index (CTJ.Caller);
2475 for K in reverse STT.Lev .. STF.Lev - 1 loop
2476 SubX := Enclosing_Subp (SubX);
2477 Extra :=
2478 Make_Selected_Component (Loc,
2479 Prefix => Extra,
2480 Selector_Name =>
2481 New_Occurrence_Of
2482 (Subps.Table (SubX).ARECnU, Loc));
2483 end loop;
2484 end if;
2485
2486 -- Extra is the additional parameter to be added. Build a
2487 -- parameter association that we can append to the actuals.
2488
2489 ExtraP :=
2490 Make_Parameter_Association (Loc,
2491 Selector_Name =>
2492 New_Occurrence_Of (STT.ARECnF, Loc),
2493 Explicit_Actual_Parameter => Extra);
2494
2495 if No (Parameter_Associations (CTJ.N)) then
2496 Set_Parameter_Associations (CTJ.N, Empty_List);
2497 end if;
2498
2499 Append (ExtraP, Parameter_Associations (CTJ.N));
2500
2501 -- We need to deal with the actual parameter chain as well. The
2502 -- newly added parameter is always the last actual.
2503
2504 Act := First_Named_Actual (CTJ.N);
2505
2506 if No (Act) then
2507 Set_First_Named_Actual (CTJ.N, Extra);
2508
2509 -- If call has been relocated (as with an expression in
2510 -- an aggregate), set First_Named pointer in original node
2511 -- as well, because that's the parent of the parameter list.
2512
2513 Set_First_Named_Actual
2514 (Parent (List_Containing (ExtraP)), Extra);
2515
2516 -- Here we must follow the chain and append the new entry
2517
2518 else
2519 loop
2520 declare
2521 PAN : Node_Id;
2522 NNA : Node_Id;
2523
2524 begin
2525 PAN := Parent (Act);
2526 pragma Assert (Nkind (PAN) = N_Parameter_Association);
2527 NNA := Next_Named_Actual (PAN);
2528
2529 if No (NNA) then
2530 Set_Next_Named_Actual (PAN, Extra);
2531 exit;
2532 end if;
2533
2534 Act := NNA;
2535 end;
2536 end loop;
2537 end if;
2538
2539 -- Analyze and resolve the new actual. We do not need to
2540 -- establish the relevant scope stack entries here, because
2541 -- we have already set all the correct entity references, so
2542 -- no name resolution is needed.
2543
2544 -- We analyze with all checks suppressed (since we do not
2545 -- expect any exceptions, and also we temporarily turn off
2546 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2547 -- references (not needed at this stage, and in fact causes
2548 -- a bit of recursive chaos).
2549
2550 Opt.Unnest_Subprogram_Mode := False;
2551 Analyze_And_Resolve
2552 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
2553 Opt.Unnest_Subprogram_Mode := True;
2554 end if;
2555 end Adjust_One_Call;
2556 end loop Adjust_Calls;
2557
2558 return;
2559 end Unnest_Subprogram;
2560
2561 ------------------------
2562 -- Unnest_Subprograms --
2563 ------------------------
2564
2565 procedure Unnest_Subprograms (N : Node_Id) is
2566 function Search_Subprograms (N : Node_Id) return Traverse_Result;
2567 -- Tree visitor that search for outer level procedures with nested
2568 -- subprograms and invokes Unnest_Subprogram()
2569
2570 ---------------
2571 -- Do_Search --
2572 ---------------
2573
2574 procedure Do_Search is new Traverse_Proc (Search_Subprograms);
2575 -- Subtree visitor instantiation
2576
2577 ------------------------
2578 -- Search_Subprograms --
2579 ------------------------
2580
2581 function Search_Subprograms (N : Node_Id) return Traverse_Result is
2582 begin
2583 if Nkind (N) in N_Subprogram_Body | N_Subprogram_Body_Stub then
2584 declare
2585 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
2586
2587 begin
2588 -- We are only interested in subprograms (not generic
2589 -- subprograms), that have nested subprograms.
2590
2591 if Is_Subprogram (Spec_Id)
2592 and then Has_Nested_Subprogram (Spec_Id)
2593 and then Is_Library_Level_Entity (Spec_Id)
2594 then
2595 Unnest_Subprogram (Spec_Id, N);
2596 else
2597 return Skip;
2598 end if;
2599 end;
2600
2601 -- The proper body of a stub may contain nested subprograms, and
2602 -- therefore must be visited explicitly. Nested stubs are examined
2603 -- recursively in Visit_Node.
2604
2605 elsif Nkind (N) in N_Body_Stub then
2606 Do_Search (Library_Unit (N));
2607
2608 -- Skip generic packages
2609
2610 elsif Nkind (N) = N_Package_Body
2611 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
2612 then
2613 return Skip;
2614 end if;
2615
2616 return OK;
2617 end Search_Subprograms;
2618
2619 Subp : Entity_Id;
2620 Subp_Body : Node_Id;
2621
2622 -- Start of processing for Unnest_Subprograms
2623
2624 begin
2625 if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then
2626 return;
2627 end if;
2628
2629 -- A specification will contain bodies if it contains instantiations so
2630 -- examine package or subprogram declaration of the main unit, when it
2631 -- is present.
2632
2633 if Nkind (Unit (N)) = N_Package_Body
2634 or else (Nkind (Unit (N)) = N_Subprogram_Body
2635 and then not Acts_As_Spec (N))
2636 then
2637 Do_Search (Library_Unit (N));
2638 end if;
2639
2640 Do_Search (N);
2641
2642 -- Unnest any subprograms passed on the list of inlined subprograms
2643
2644 Subp := First_Inlined_Subprogram (N);
2645
2646 while Present (Subp) loop
2647 Subp_Body := Parent (Declaration_Node (Subp));
2648
2649 if Nkind (Subp_Body) = N_Subprogram_Declaration
2650 and then Present (Corresponding_Body (Subp_Body))
2651 then
2652 Subp_Body := Parent (Declaration_Node
2653 (Corresponding_Body (Subp_Body)));
2654 end if;
2655
2656 Unnest_Subprogram (Subp, Subp_Body, For_Inline => True);
2657 Next_Inlined_Subprogram (Subp);
2658 end loop;
2659 end Unnest_Subprograms;
2660
2661 end Exp_Unst;
Mirror of the offical gcc git repository hosted at gcc.gnu.org