File : exp_unst.adb
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-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 Debug; use Debug;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Lib; use Lib;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Opt; use Opt;
35 with Output; use Output;
36 with Rtsfind; use Rtsfind;
37 with Sem; use Sem;
38 with Sem_Ch8; use Sem_Ch8;
39 with Sem_Mech; use Sem_Mech;
40 with Sem_Res; use Sem_Res;
41 with Sem_Util; use Sem_Util;
42 with Sinfo; use Sinfo;
43 with Sinput; use Sinput;
44 with Snames; use Snames;
45 with Tbuild; use Tbuild;
46 with Uintp; use Uintp;
47
48 package body Exp_Unst is
49
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
53
54 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
55 -- Subp is a library-level subprogram which has nested subprograms, and
56 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
57 -- declares the AREC types and objects, adds assignments to the AREC record
58 -- as required, defines the xxxPTR types for uplevel referenced objects,
59 -- adds the ARECP parameter to all nested subprograms which need it, and
60 -- modifies all uplevel references appropriately.
61
62 -----------
63 -- Calls --
64 -----------
65
66 -- Table to record calls within the nest being analyzed. These are the
67 -- calls which may need to have an AREC actual added. This table is built
68 -- new for each subprogram nest and cleared at the end of processing each
69 -- subprogram nest.
70
71 type Call_Entry is record
72 N : Node_Id;
73 -- The actual call
74
75 Caller : Entity_Id;
76 -- Entity of the subprogram containing the call (can be at any level)
77
78 Callee : Entity_Id;
79 -- Entity of the subprogram called (always at level 2 or higher). Note
80 -- that in accordance with the basic rules of nesting, the level of To
81 -- is either less than or equal to the level of From, or one greater.
82 end record;
83
84 package Calls is new Table.Table (
85 Table_Component_Type => Call_Entry,
86 Table_Index_Type => Nat,
87 Table_Low_Bound => 1,
88 Table_Initial => 100,
89 Table_Increment => 200,
90 Table_Name => "Unnest_Calls");
91 -- Records each call within the outer subprogram and all nested subprograms
92 -- that are to other subprograms nested within the outer subprogram. These
93 -- are the calls that may need an additional parameter.
94
95 procedure Append_Unique_Call (Call : Call_Entry);
96 -- Append a call entry to the Calls table. A check is made to see if the
97 -- table already contains this entry and if so it has no effect.
98
99 -----------
100 -- Urefs --
101 -----------
102
103 -- Table to record explicit uplevel references to objects (variables,
104 -- constants, formal parameters). These are the references that will
105 -- need rewriting to use the activation table (AREC) pointers. Also
106 -- included are implicit and explicit uplevel references to types, but
107 -- these do not get rewritten by the front end. This table is built new
108 -- for each subprogram nest and cleared at the end of processing each
109 -- subprogram nest.
110
111 type Uref_Entry is record
112 Ref : Node_Id;
113 -- The reference itself. For objects this is always an entity reference
114 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
115 -- flag set and will appear in the Uplevel_Referenced_Entities list of
116 -- the subprogram declaring this entity.
117
118 Ent : Entity_Id;
119 -- The Entity_Id of the uplevel referenced object or type
120
121 Caller : Entity_Id;
122 -- The entity for the subprogram immediately containing this entity
123
124 Callee : Entity_Id;
125 -- The entity for the subprogram containing the referenced entity. Note
126 -- that the level of Callee must be less than the level of Caller, since
127 -- this is an uplevel reference.
128 end record;
129
130 package Urefs is new Table.Table (
131 Table_Component_Type => Uref_Entry,
132 Table_Index_Type => Nat,
133 Table_Low_Bound => 1,
134 Table_Initial => 100,
135 Table_Increment => 200,
136 Table_Name => "Unnest_Urefs");
137
138 ------------------------
139 -- Append_Unique_Call --
140 ------------------------
141
142 procedure Append_Unique_Call (Call : Call_Entry) is
143 begin
144 for J in Calls.First .. Calls.Last loop
145 if Calls.Table (J) = Call then
146 return;
147 end if;
148 end loop;
149
150 Calls.Append (Call);
151 end Append_Unique_Call;
152
153 ---------------
154 -- Get_Level --
155 ---------------
156
157 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
158 Lev : Nat;
159 S : Entity_Id;
160
161 begin
162 Lev := 1;
163 S := Sub;
164 loop
165 if S = Subp then
166 return Lev;
167 else
168 Lev := Lev + 1;
169 S := Enclosing_Subprogram (S);
170 end if;
171 end loop;
172 end Get_Level;
173
174 ----------------
175 -- Subp_Index --
176 ----------------
177
178 function Subp_Index (Sub : Entity_Id) return SI_Type is
179 begin
180 pragma Assert (Is_Subprogram (Sub));
181 return SI_Type (UI_To_Int (Subps_Index (Sub)));
182 end Subp_Index;
183
184 -----------------------
185 -- Unnest_Subprogram --
186 -----------------------
187
188 procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
189 function AREC_Name (J : Pos; S : String) return Name_Id;
190 -- Returns name for string ARECjS, where j is the decimal value of j
191
192 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
193 -- Subp is the index of a subprogram which has a Lev greater than 1.
194 -- This function returns the index of the enclosing subprogram which
195 -- will have a Lev value one less than this.
196
197 function Img_Pos (N : Pos) return String;
198 -- Return image of N without leading blank
199
200 function Upref_Name
201 (Ent : Entity_Id;
202 Index : Pos;
203 Clist : List_Id) return Name_Id;
204 -- This function returns the name to be used in the activation record to
205 -- reference the variable uplevel. Clist is the list of components that
206 -- have been created in the activation record so far. Normally the name
207 -- is just a copy of the Chars field of the entity. The exception is
208 -- when the name has already been used, in which case we suffix the name
209 -- with the index value Index to avoid duplication. This happens with
210 -- declare blocks and generic parameters at least.
211
212 ---------------
213 -- AREC_Name --
214 ---------------
215
216 function AREC_Name (J : Pos; S : String) return Name_Id is
217 begin
218 return Name_Find ("AREC" & Img_Pos (J) & S);
219 end AREC_Name;
220
221 --------------------
222 -- Enclosing_Subp --
223 --------------------
224
225 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
226 STJ : Subp_Entry renames Subps.Table (Subp);
227 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
228 begin
229 pragma Assert (STJ.Lev > 1);
230 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
231 return Ret;
232 end Enclosing_Subp;
233
234 -------------
235 -- Img_Pos --
236 -------------
237
238 function Img_Pos (N : Pos) return String is
239 Buf : String (1 .. 20);
240 Ptr : Natural;
241 NV : Nat;
242
243 begin
244 Ptr := Buf'Last;
245 NV := N;
246 while NV /= 0 loop
247 Buf (Ptr) := Character'Val (48 + NV mod 10);
248 Ptr := Ptr - 1;
249 NV := NV / 10;
250 end loop;
251
252 return Buf (Ptr + 1 .. Buf'Last);
253 end Img_Pos;
254
255 ----------------
256 -- Upref_Name --
257 ----------------
258
259 function Upref_Name
260 (Ent : Entity_Id;
261 Index : Pos;
262 Clist : List_Id) return Name_Id
263 is
264 C : Node_Id;
265 begin
266 C := First (Clist);
267 loop
268 if No (C) then
269 return Chars (Ent);
270
271 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
272 return
273 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
274 else
275 Next (C);
276 end if;
277 end loop;
278 end Upref_Name;
279
280 -- Start of processing for Unnest_Subprogram
281
282 begin
283 -- Nothing to do inside a generic (all processing is for instance)
284
285 if Inside_A_Generic then
286 return;
287 end if;
288
289 -- At least for now, do not unnest anything but main source unit
290
291 if not In_Extended_Main_Source_Unit (Subp_Body) then
292 return;
293 end if;
294
295 -- This routine is called late, after the scope stack is gone. The
296 -- following creates a suitable dummy scope stack to be used for the
297 -- analyze/expand calls made from this routine.
298
299 Push_Scope (Subp);
300
301 -- First step, we must mark all nested subprograms that require a static
302 -- link (activation record) because either they contain explicit uplevel
303 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
304 -- this point), or they make calls to other subprograms in the same nest
305 -- that require a static link (in which case we set this flag).
306
307 -- This is a recursive definition, and to implement this, we have to
308 -- build a call graph for the set of nested subprograms, and then go
309 -- over this graph to implement recursively the invariant that if a
310 -- subprogram has a call to a subprogram requiring a static link, then
311 -- the calling subprogram requires a static link.
312
313 -- First populate the above tables
314
315 Subps_First := Subps.Last + 1;
316 Calls.Init;
317 Urefs.Init;
318
319 Build_Tables : declare
320 Current_Subprogram : Entity_Id;
321 -- When we scan a subprogram body, we set Current_Subprogram to the
322 -- corresponding entity. This gets recursively saved and restored.
323
324 function Visit_Node (N : Node_Id) return Traverse_Result;
325 -- Visit a single node in Subp
326
327 -----------
328 -- Visit --
329 -----------
330
331 procedure Visit is new Traverse_Proc (Visit_Node);
332 -- Used to traverse the body of Subp, populating the tables
333
334 ----------------
335 -- Visit_Node --
336 ----------------
337
338 function Visit_Node (N : Node_Id) return Traverse_Result is
339 Ent : Entity_Id;
340 Caller : Entity_Id;
341 Callee : Entity_Id;
342
343 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean);
344 -- Given a type T, checks if it is a static type defined as a type
345 -- with no dynamic bounds in sight. If so, the only action is to
346 -- set Is_Static_Type True for T. If T is not a static type, then
347 -- all types with dynamic bounds associated with T are detected,
348 -- and their bounds are marked as uplevel referenced if not at the
349 -- library level, and DT is set True.
350
351 procedure Note_Uplevel_Ref
352 (E : Entity_Id;
353 Caller : Entity_Id;
354 Callee : Entity_Id);
355 -- Called when we detect an explicit or implicit uplevel reference
356 -- from within Caller to entity E declared in Callee. E can be a
357 -- an object or a type.
358
359 -----------------------
360 -- Check_Static_Type --
361 -----------------------
362
363 procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is
364 procedure Note_Uplevel_Bound (N : Node_Id);
365 -- N is the bound of a dynamic type. This procedure notes that
366 -- this bound is uplevel referenced, it can handle references
367 -- to entities (typically _FIRST and _LAST entities), and also
368 -- attribute references of the form T'name (name is typically
369 -- FIRST or LAST) where T is the uplevel referenced bound.
370
371 ------------------------
372 -- Note_Uplevel_Bound --
373 ------------------------
374
375 procedure Note_Uplevel_Bound (N : Node_Id) is
376 begin
377 -- Entity name case
378
379 if Is_Entity_Name (N) then
380 if Present (Entity (N)) then
381 Note_Uplevel_Ref
382 (E => Entity (N),
383 Caller => Current_Subprogram,
384 Callee => Enclosing_Subprogram (Entity (N)));
385 end if;
386
387 -- Attribute case
388
389 elsif Nkind (N) = N_Attribute_Reference then
390 Note_Uplevel_Bound (Prefix (N));
391 end if;
392 end Note_Uplevel_Bound;
393
394 -- Start of processing for Check_Static_Type
395
396 begin
397 -- If already marked static, immediate return
398
399 if Is_Static_Type (T) then
400 return;
401 end if;
402
403 -- If the type is at library level, always consider it static,
404 -- since such uplevel references are irrelevant.
405
406 if Is_Library_Level_Entity (T) then
407 Set_Is_Static_Type (T);
408 return;
409 end if;
410
411 -- Otherwise figure out what the story is with this type
412
413 -- For a scalar type, check bounds
414
415 if Is_Scalar_Type (T) then
416
417 -- If both bounds static, then this is a static type
418
419 declare
420 LB : constant Node_Id := Type_Low_Bound (T);
421 UB : constant Node_Id := Type_High_Bound (T);
422
423 begin
424 if not Is_Static_Expression (LB) then
425 Note_Uplevel_Bound (LB);
426 DT := True;
427 end if;
428
429 if not Is_Static_Expression (UB) then
430 Note_Uplevel_Bound (UB);
431 DT := True;
432 end if;
433 end;
434
435 -- For record type, check all components
436
437 elsif Is_Record_Type (T) then
438 declare
439 C : Entity_Id;
440 begin
441 C := First_Component_Or_Discriminant (T);
442 while Present (C) loop
443 Check_Static_Type (Etype (C), DT);
444 Next_Component_Or_Discriminant (C);
445 end loop;
446 end;
447
448 -- For array type, check index types and component type
449
450 elsif Is_Array_Type (T) then
451 declare
452 IX : Node_Id;
453 begin
454 Check_Static_Type (Component_Type (T), DT);
455
456 IX := First_Index (T);
457 while Present (IX) loop
458 Check_Static_Type (Etype (IX), DT);
459 Next_Index (IX);
460 end loop;
461 end;
462
463 -- For private type, examine whether full view is static
464
465 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
466 Check_Static_Type (Full_View (T), DT);
467
468 if Is_Static_Type (Full_View (T)) then
469 Set_Is_Static_Type (T);
470 end if;
471
472 -- For now, ignore other types
473
474 else
475 return;
476 end if;
477
478 if not DT then
479 Set_Is_Static_Type (T);
480 end if;
481 end Check_Static_Type;
482
483 ----------------------
484 -- Note_Uplevel_Ref --
485 ----------------------
486
487 procedure Note_Uplevel_Ref
488 (E : Entity_Id;
489 Caller : Entity_Id;
490 Callee : Entity_Id)
491 is
492 begin
493 -- Nothing to do for static type
494
495 if Is_Static_Type (E) then
496 return;
497 end if;
498
499 -- Nothing to do if Caller and Callee are the same
500
501 if Caller = Callee then
502 return;
503
504 -- Callee may be a function that returns an array, and that has
505 -- been rewritten as a procedure. If caller is that procedure,
506 -- nothing to do either.
507
508 elsif Ekind (Callee) = E_Function
509 and then Rewritten_For_C (Callee)
510 and then Corresponding_Procedure (Callee) = Caller
511 then
512 return;
513 end if;
514
515 -- We have a new uplevel referenced entity
516
517 -- All we do at this stage is to add the uplevel reference to
518 -- the table. It's too early to do anything else, since this
519 -- uplevel reference may come from an unreachable subprogram
520 -- in which case the entry will be deleted.
521
522 Urefs.Append ((N, E, Caller, Callee));
523 end Note_Uplevel_Ref;
524
525 -- Start of processing for Visit_Node
526
527 begin
528 -- Record a call
529
530 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
531
532 -- We are only interested in direct calls, not indirect calls
533 -- (where Name (N) is an explicit dereference) at least for now!
534
535 and then Nkind (Name (N)) in N_Has_Entity
536 then
537 Ent := Entity (Name (N));
538
539 -- We are only interested in calls to subprograms nested
540 -- within Subp. Calls to Subp itself or to subprograms that
541 -- are outside the nested structure do not affect us.
542
543 if Scope_Within (Ent, Subp) then
544
545 -- Ignore calls to imported routines
546
547 if Is_Imported (Ent) then
548 null;
549
550 -- Here we have a call to keep and analyze
551
552 else
553 -- Both caller and callee must be subprograms
554
555 if Is_Subprogram (Ent) then
556 Append_Unique_Call ((N, Current_Subprogram, Ent));
557 end if;
558 end if;
559 end if;
560
561 -- Record a subprogram. We record a subprogram body that acts as
562 -- a spec. Otherwise we record a subprogram declaration, providing
563 -- that it has a corresponding body we can get hold of. The case
564 -- of no corresponding body being available is ignored for now.
565
566 elsif Nkind (N) = N_Subprogram_Body then
567 Ent := Unique_Defining_Entity (N);
568
569 -- Ignore generic subprogram
570
571 if Is_Generic_Subprogram (Ent) then
572 return Skip;
573 end if;
574
575 -- Make new entry in subprogram table if not already made
576
577 declare
578 L : constant Nat := Get_Level (Subp, Ent);
579 begin
580 Subps.Append
581 ((Ent => Ent,
582 Bod => N,
583 Lev => L,
584 Reachable => False,
585 Uplevel_Ref => L,
586 Declares_AREC => False,
587 Uents => No_Elist,
588 Last => 0,
589 ARECnF => Empty,
590 ARECn => Empty,
591 ARECnT => Empty,
592 ARECnPT => Empty,
593 ARECnP => Empty,
594 ARECnU => Empty));
595 Set_Subps_Index (Ent, UI_From_Int (Subps.Last));
596 end;
597
598 -- We make a recursive call to scan the subprogram body, so
599 -- that we can save and restore Current_Subprogram.
600
601 declare
602 Save_CS : constant Entity_Id := Current_Subprogram;
603 Decl : Node_Id;
604
605 begin
606 Current_Subprogram := Ent;
607
608 -- Scan declarations
609
610 Decl := First (Declarations (N));
611 while Present (Decl) loop
612 Visit (Decl);
613 Next (Decl);
614 end loop;
615
616 -- Scan statements
617
618 Visit (Handled_Statement_Sequence (N));
619
620 -- Restore current subprogram setting
621
622 Current_Subprogram := Save_CS;
623 end;
624
625 -- Now at this level, return skipping the subprogram body
626 -- descendants, since we already took care of them!
627
628 return Skip;
629
630 -- Record an uplevel reference
631
632 elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then
633 Ent := Entity (N);
634
635 -- Only interested in entities declared within our nest
636
637 if not Is_Library_Level_Entity (Ent)
638 and then Scope_Within_Or_Same (Scope (Ent), Subp)
639
640 -- Skip entities defined in inlined subprograms
641
642 and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
643 and then
644
645 -- Constants and variables are interesting
646
647 (Ekind_In (Ent, E_Constant, E_Variable)
648
649 -- Formals are interesting, but not if being used as mere
650 -- names of parameters for name notation calls.
651
652 or else
653 (Is_Formal (Ent)
654 and then not
655 (Nkind (Parent (N)) = N_Parameter_Association
656 and then Selector_Name (Parent (N)) = N))
657
658 -- Types other than known Is_Static types are interesting
659
660 or else (Is_Type (Ent)
661 and then not Is_Static_Type (Ent)))
662 then
663 -- Here we have a possible interesting uplevel reference
664
665 if Is_Type (Ent) then
666 declare
667 DT : Boolean := False;
668
669 begin
670 Check_Static_Type (Ent, DT);
671
672 if Is_Static_Type (Ent) then
673 return OK;
674 end if;
675 end;
676 end if;
677
678 Caller := Current_Subprogram;
679 Callee := Enclosing_Subprogram (Ent);
680
681 if Callee /= Caller and then not Is_Static_Type (Ent) then
682 Note_Uplevel_Ref (Ent, Caller, Callee);
683 end if;
684 end if;
685
686 -- If we have a body stub, visit the associated subunit
687
688 elsif Nkind (N) in N_Body_Stub then
689 Visit (Library_Unit (N));
690
691 -- Skip generic declarations
692
693 elsif Nkind (N) in N_Generic_Declaration then
694 return Skip;
695
696 -- Skip generic package body
697
698 elsif Nkind (N) = N_Package_Body
699 and then Present (Corresponding_Spec (N))
700 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
701 then
702 return Skip;
703 end if;
704
705 -- Fall through to continue scanning children of this node
706
707 return OK;
708 end Visit_Node;
709
710 -- Start of processing for Build_Tables
711
712 begin
713 -- Traverse the body to get subprograms, calls and uplevel references
714
715 Visit (Subp_Body);
716 end Build_Tables;
717
718 -- Now do the first transitive closure which determines which
719 -- subprograms in the nest are actually reachable.
720
721 Reachable_Closure : declare
722 Modified : Boolean;
723
724 begin
725 Subps.Table (Subps_First).Reachable := True;
726
727 -- We use a simple minded algorithm as follows (obviously this can
728 -- be done more efficiently, using one of the standard algorithms
729 -- for efficient transitive closure computation, but this is simple
730 -- and most likely fast enough that its speed does not matter).
731
732 -- Repeatedly scan the list of calls. Any time we find a call from
733 -- A to B, where A is reachable, but B is not, then B is reachable,
734 -- and note that we have made a change by setting Modified True. We
735 -- repeat this until we make a pass with no modifications.
736
737 Outer : loop
738 Modified := False;
739 Inner : for J in Calls.First .. Calls.Last loop
740 declare
741 CTJ : Call_Entry renames Calls.Table (J);
742
743 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
744 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
745
746 SUBF : Subp_Entry renames Subps.Table (SINF);
747 SUBT : Subp_Entry renames Subps.Table (SINT);
748
749 begin
750 if SUBF.Reachable and then not SUBT.Reachable then
751 SUBT.Reachable := True;
752 Modified := True;
753 end if;
754 end;
755 end loop Inner;
756
757 exit Outer when not Modified;
758 end loop Outer;
759 end Reachable_Closure;
760
761 -- Remove calls from unreachable subprograms
762
763 declare
764 New_Index : Nat;
765
766 begin
767 New_Index := 0;
768 for J in Calls.First .. Calls.Last loop
769 declare
770 CTJ : Call_Entry renames Calls.Table (J);
771
772 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
773 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
774
775 SUBF : Subp_Entry renames Subps.Table (SINF);
776 SUBT : Subp_Entry renames Subps.Table (SINT);
777
778 begin
779 if SUBF.Reachable then
780 pragma Assert (SUBT.Reachable);
781 New_Index := New_Index + 1;
782 Calls.Table (New_Index) := Calls.Table (J);
783 end if;
784 end;
785 end loop;
786
787 Calls.Set_Last (New_Index);
788 end;
789
790 -- Remove uplevel references from unreachable subprograms
791
792 declare
793 New_Index : Nat;
794
795 begin
796 New_Index := 0;
797 for J in Urefs.First .. Urefs.Last loop
798 declare
799 URJ : Uref_Entry renames Urefs.Table (J);
800
801 SINF : constant SI_Type := Subp_Index (URJ.Caller);
802 SINT : constant SI_Type := Subp_Index (URJ.Callee);
803
804 SUBF : Subp_Entry renames Subps.Table (SINF);
805 SUBT : Subp_Entry renames Subps.Table (SINT);
806
807 S : Entity_Id;
808
809 begin
810 -- Keep reachable reference
811
812 if SUBF.Reachable then
813 New_Index := New_Index + 1;
814 Urefs.Table (New_Index) := Urefs.Table (J);
815
816 -- And since we know we are keeping this one, this is a good
817 -- place to fill in information for a good reference.
818
819 -- Mark all enclosing subprograms need to declare AREC
820
821 S := URJ.Caller;
822 loop
823 S := Enclosing_Subprogram (S);
824
825 -- if we are at the top level, as can happen with
826 -- references to formals in aspects of nested subprogram
827 -- declarations, there are no further subprograms to
828 -- mark as requiring activation records.
829
830 exit when No (S);
831 Subps.Table (Subp_Index (S)).Declares_AREC := True;
832 exit when S = URJ.Callee;
833 end loop;
834
835 -- Add to list of uplevel referenced entities for Callee.
836 -- We do not add types to this list, only actual references
837 -- to objects that will be referenced uplevel, and we use
838 -- the flag Is_Uplevel_Referenced_Entity to avoid making
839 -- duplicate entries in the list.
840
841 if not Is_Uplevel_Referenced_Entity (URJ.Ent) then
842 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
843
844 if not Is_Type (URJ.Ent) then
845 Append_New_Elmt (URJ.Ent, SUBT.Uents);
846 end if;
847 end if;
848
849 -- And set uplevel indication for caller
850
851 if SUBT.Lev < SUBF.Uplevel_Ref then
852 SUBF.Uplevel_Ref := SUBT.Lev;
853 end if;
854 end if;
855 end;
856 end loop;
857
858 Urefs.Set_Last (New_Index);
859 end;
860
861 -- Remove unreachable subprograms from Subps table. Note that we do
862 -- this after eliminating entries from the other two tables, since
863 -- those elimination steps depend on referencing the Subps table.
864
865 declare
866 New_SI : SI_Type;
867
868 begin
869 New_SI := Subps_First - 1;
870 for J in Subps_First .. Subps.Last loop
871 declare
872 STJ : Subp_Entry renames Subps.Table (J);
873 Spec : Node_Id;
874 Decl : Node_Id;
875
876 begin
877 -- Subprogram is reachable, copy and reset index
878
879 if STJ.Reachable then
880 New_SI := New_SI + 1;
881 Subps.Table (New_SI) := STJ;
882 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
883
884 -- Subprogram is not reachable
885
886 else
887 -- Clear index, since no longer active
888
889 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
890
891 -- Output debug information if -gnatd.3 set
892
893 if Debug_Flag_Dot_3 then
894 Write_Str ("Eliminate ");
895 Write_Name (Chars (Subps.Table (J).Ent));
896 Write_Str (" at ");
897 Write_Location (Sloc (Subps.Table (J).Ent));
898 Write_Str (" (not referenced)");
899 Write_Eol;
900 end if;
901
902 -- Rewrite declaration and body to null statements
903
904 Spec := Corresponding_Spec (STJ.Bod);
905
906 if Present (Spec) then
907 Decl := Parent (Declaration_Node (Spec));
908 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
909 end if;
910
911 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
912 end if;
913 end;
914 end loop;
915
916 Subps.Set_Last (New_SI);
917 end;
918
919 -- Now it is time for the second transitive closure, which follows calls
920 -- and makes sure that A calls B, and B has uplevel references, then A
921 -- is also marked as having uplevel references.
922
923 Closure_Uplevel : declare
924 Modified : Boolean;
925
926 begin
927 -- We use a simple minded algorithm as follows (obviously this can
928 -- be done more efficiently, using one of the standard algorithms
929 -- for efficient transitive closure computation, but this is simple
930 -- and most likely fast enough that its speed does not matter).
931
932 -- Repeatedly scan the list of calls. Any time we find a call from
933 -- A to B, where B has uplevel references, make sure that A is marked
934 -- as having at least the same level of uplevel referencing.
935
936 Outer2 : loop
937 Modified := False;
938 Inner2 : for J in Calls.First .. Calls.Last loop
939 declare
940 CTJ : Call_Entry renames Calls.Table (J);
941 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
942 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
943 SUBF : Subp_Entry renames Subps.Table (SINF);
944 SUBT : Subp_Entry renames Subps.Table (SINT);
945 begin
946 if SUBT.Lev > SUBT.Uplevel_Ref
947 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
948 then
949 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
950 Modified := True;
951 end if;
952 end;
953 end loop Inner2;
954
955 exit Outer2 when not Modified;
956 end loop Outer2;
957 end Closure_Uplevel;
958
959 -- We have one more step before the tables are complete. An uplevel
960 -- call from subprogram A to subprogram B where subprogram B has uplevel
961 -- references is in effect an uplevel reference, and must arrange for
962 -- the proper activation link to be passed.
963
964 for J in Calls.First .. Calls.Last loop
965 declare
966 CTJ : Call_Entry renames Calls.Table (J);
967
968 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
969 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
970
971 SUBF : Subp_Entry renames Subps.Table (SINF);
972 SUBT : Subp_Entry renames Subps.Table (SINT);
973
974 A : Entity_Id;
975
976 begin
977 -- If callee has uplevel references
978
979 if SUBT.Uplevel_Ref < SUBT.Lev
980
981 -- And this is an uplevel call
982
983 and then SUBT.Lev < SUBF.Lev
984 then
985 -- We need to arrange for finding the uplink
986
987 A := CTJ.Caller;
988 loop
989 A := Enclosing_Subprogram (A);
990 Subps.Table (Subp_Index (A)).Declares_AREC := True;
991 exit when A = CTJ.Callee;
992
993 -- In any case exit when we get to the outer level. This
994 -- happens in some odd cases with generics (in particular
995 -- sem_ch3.adb does not compile without this kludge ???).
996
997 exit when A = Subp;
998 end loop;
999 end if;
1000 end;
1001 end loop;
1002
1003 -- The tables are now complete, so we can record the last index in the
1004 -- Subps table for later reference in Cprint.
1005
1006 Subps.Table (Subps_First).Last := Subps.Last;
1007
1008 -- Next step, create the entities for code we will insert. We do this
1009 -- at the start so that all the entities are defined, regardless of the
1010 -- order in which we do the code insertions.
1011
1012 Create_Entities : for J in Subps_First .. Subps.Last loop
1013 declare
1014 STJ : Subp_Entry renames Subps.Table (J);
1015 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1016
1017 begin
1018 -- First we create the ARECnF entity for the additional formal for
1019 -- all subprograms which need an activation record passed.
1020
1021 if STJ.Uplevel_Ref < STJ.Lev then
1022 STJ.ARECnF :=
1023 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
1024 end if;
1025
1026 -- Define the AREC entities for the activation record if needed
1027
1028 if STJ.Declares_AREC then
1029 STJ.ARECn :=
1030 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
1031 STJ.ARECnT :=
1032 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
1033 STJ.ARECnPT :=
1034 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
1035 STJ.ARECnP :=
1036 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
1037
1038 -- Define uplink component entity if inner nesting case
1039
1040 if Present (STJ.ARECnF) then
1041 STJ.ARECnU :=
1042 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1043 end if;
1044 end if;
1045 end;
1046 end loop Create_Entities;
1047
1048 -- Loop through subprograms
1049
1050 Subp_Loop : declare
1051 Addr : constant Entity_Id := RTE (RE_Address);
1052
1053 begin
1054 for J in Subps_First .. Subps.Last loop
1055 declare
1056 STJ : Subp_Entry renames Subps.Table (J);
1057
1058 begin
1059 -- First add the extra formal if needed. This applies to all
1060 -- nested subprograms that require an activation record to be
1061 -- passed, as indicated by ARECnF being defined.
1062
1063 if Present (STJ.ARECnF) then
1064
1065 -- Here we need the extra formal. We do the expansion and
1066 -- analysis of this manually, since it is fairly simple,
1067 -- and it is not obvious how we can get what we want if we
1068 -- try to use the normal Analyze circuit.
1069
1070 Add_Extra_Formal : declare
1071 Encl : constant SI_Type := Enclosing_Subp (J);
1072 STJE : Subp_Entry renames Subps.Table (Encl);
1073 -- Index and Subp_Entry for enclosing routine
1074
1075 Form : constant Entity_Id := STJ.ARECnF;
1076 -- The formal to be added. Note that n here is one less
1077 -- than the level of the subprogram itself (STJ.Ent).
1078
1079 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1080 -- S is an N_Function/Procedure_Specification node, and F
1081 -- is the new entity to add to this subprogramn spec as
1082 -- the last Extra_Formal.
1083
1084 ----------------------
1085 -- Add_Form_To_Spec --
1086 ----------------------
1087
1088 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1089 Sub : constant Entity_Id := Defining_Entity (S);
1090 Ent : Entity_Id;
1091
1092 begin
1093 -- Case of at least one Extra_Formal is present, set
1094 -- ARECnF as the new last entry in the list.
1095
1096 if Present (Extra_Formals (Sub)) then
1097 Ent := Extra_Formals (Sub);
1098 while Present (Extra_Formal (Ent)) loop
1099 Ent := Extra_Formal (Ent);
1100 end loop;
1101
1102 Set_Extra_Formal (Ent, F);
1103
1104 -- No Extra formals present
1105
1106 else
1107 Set_Extra_Formals (Sub, F);
1108 Ent := Last_Formal (Sub);
1109
1110 if Present (Ent) then
1111 Set_Extra_Formal (Ent, F);
1112 end if;
1113 end if;
1114 end Add_Form_To_Spec;
1115
1116 -- Start of processing for Add_Extra_Formal
1117
1118 begin
1119 -- Decorate the new formal entity
1120
1121 Set_Scope (Form, STJ.Ent);
1122 Set_Ekind (Form, E_In_Parameter);
1123 Set_Etype (Form, STJE.ARECnPT);
1124 Set_Mechanism (Form, By_Copy);
1125 Set_Never_Set_In_Source (Form, True);
1126 Set_Analyzed (Form, True);
1127 Set_Comes_From_Source (Form, False);
1128
1129 -- Case of only body present
1130
1131 if Acts_As_Spec (STJ.Bod) then
1132 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1133
1134 -- Case of separate spec
1135
1136 else
1137 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1138 end if;
1139 end Add_Extra_Formal;
1140 end if;
1141
1142 -- Processing for subprograms that declare an activation record
1143
1144 if Present (STJ.ARECn) then
1145
1146 -- Local declarations for one such subprogram
1147
1148 declare
1149 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1150 Clist : List_Id;
1151 Comp : Entity_Id;
1152
1153 Decl_ARECnT : Node_Id;
1154 Decl_ARECnPT : Node_Id;
1155 Decl_ARECn : Node_Id;
1156 Decl_ARECnP : Node_Id;
1157 -- Declaration nodes for the AREC entities we build
1158
1159 Decl_Assign : Node_Id;
1160 -- Assigment to set uplink, Empty if none
1161
1162 Decls : List_Id;
1163 -- List of new declarations we create
1164
1165 begin
1166 -- Build list of component declarations for ARECnT
1167
1168 Clist := Empty_List;
1169
1170 -- If we are in a subprogram that has a static link that
1171 -- is passed in (as indicated by ARECnF being defined),
1172 -- then include ARECnU : ARECmPT where ARECmPT comes from
1173 -- the level one higher than the current level, and the
1174 -- entity ARECnPT comes from the enclosing subprogram.
1175
1176 if Present (STJ.ARECnF) then
1177 declare
1178 STJE : Subp_Entry
1179 renames Subps.Table (Enclosing_Subp (J));
1180 begin
1181 Append_To (Clist,
1182 Make_Component_Declaration (Loc,
1183 Defining_Identifier => STJ.ARECnU,
1184 Component_Definition =>
1185 Make_Component_Definition (Loc,
1186 Subtype_Indication =>
1187 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1188 end;
1189 end if;
1190
1191 -- Add components for uplevel referenced entities
1192
1193 if Present (STJ.Uents) then
1194 declare
1195 Elmt : Elmt_Id;
1196 Uent : Entity_Id;
1197
1198 Indx : Nat;
1199 -- 1's origin of index in list of elements. This is
1200 -- used to uniquify names if needed in Upref_Name.
1201
1202 begin
1203 Elmt := First_Elmt (STJ.Uents);
1204 Indx := 0;
1205 while Present (Elmt) loop
1206 Uent := Node (Elmt);
1207 Indx := Indx + 1;
1208
1209 Comp :=
1210 Make_Defining_Identifier (Loc,
1211 Chars => Upref_Name (Uent, Indx, Clist));
1212
1213 Set_Activation_Record_Component
1214 (Uent, Comp);
1215
1216 Append_To (Clist,
1217 Make_Component_Declaration (Loc,
1218 Defining_Identifier => Comp,
1219 Component_Definition =>
1220 Make_Component_Definition (Loc,
1221 Subtype_Indication =>
1222 New_Occurrence_Of (Addr, Loc))));
1223
1224 Next_Elmt (Elmt);
1225 end loop;
1226 end;
1227 end if;
1228
1229 -- Now we can insert the AREC declarations into the body
1230
1231 -- type ARECnT is record .. end record;
1232 -- pragma Suppress_Initialization (ARECnT);
1233
1234 -- Note that we need to set the Suppress_Initialization
1235 -- flag after Decl_ARECnT has been analyzed.
1236
1237 Decl_ARECnT :=
1238 Make_Full_Type_Declaration (Loc,
1239 Defining_Identifier => STJ.ARECnT,
1240 Type_Definition =>
1241 Make_Record_Definition (Loc,
1242 Component_List =>
1243 Make_Component_List (Loc,
1244 Component_Items => Clist)));
1245 Decls := New_List (Decl_ARECnT);
1246
1247 -- type ARECnPT is access all ARECnT;
1248
1249 Decl_ARECnPT :=
1250 Make_Full_Type_Declaration (Loc,
1251 Defining_Identifier => STJ.ARECnPT,
1252 Type_Definition =>
1253 Make_Access_To_Object_Definition (Loc,
1254 All_Present => True,
1255 Subtype_Indication =>
1256 New_Occurrence_Of (STJ.ARECnT, Loc)));
1257 Append_To (Decls, Decl_ARECnPT);
1258
1259 -- ARECn : aliased ARECnT;
1260
1261 Decl_ARECn :=
1262 Make_Object_Declaration (Loc,
1263 Defining_Identifier => STJ.ARECn,
1264 Aliased_Present => True,
1265 Object_Definition =>
1266 New_Occurrence_Of (STJ.ARECnT, Loc));
1267 Append_To (Decls, Decl_ARECn);
1268
1269 -- ARECnP : constant ARECnPT := ARECn'Access;
1270
1271 Decl_ARECnP :=
1272 Make_Object_Declaration (Loc,
1273 Defining_Identifier => STJ.ARECnP,
1274 Constant_Present => True,
1275 Object_Definition =>
1276 New_Occurrence_Of (STJ.ARECnPT, Loc),
1277 Expression =>
1278 Make_Attribute_Reference (Loc,
1279 Prefix =>
1280 New_Occurrence_Of (STJ.ARECn, Loc),
1281 Attribute_Name => Name_Access));
1282 Append_To (Decls, Decl_ARECnP);
1283
1284 -- If we are in a subprogram that has a static link that
1285 -- is passed in (as indicated by ARECnF being defined),
1286 -- then generate ARECn.ARECmU := ARECmF where m is
1287 -- one less than the current level to set the uplink.
1288
1289 if Present (STJ.ARECnF) then
1290 Decl_Assign :=
1291 Make_Assignment_Statement (Loc,
1292 Name =>
1293 Make_Selected_Component (Loc,
1294 Prefix =>
1295 New_Occurrence_Of (STJ.ARECn, Loc),
1296 Selector_Name =>
1297 New_Occurrence_Of (STJ.ARECnU, Loc)),
1298 Expression =>
1299 New_Occurrence_Of (STJ.ARECnF, Loc));
1300 Append_To (Decls, Decl_Assign);
1301
1302 else
1303 Decl_Assign := Empty;
1304 end if;
1305
1306 Prepend_List_To (Declarations (STJ.Bod), Decls);
1307
1308 -- Analyze the newly inserted declarations. Note that we
1309 -- do not need to establish the whole scope stack, since
1310 -- we have already set all entity fields (so there will
1311 -- be no searching of upper scopes to resolve names). But
1312 -- we do set the scope of the current subprogram, so that
1313 -- newly created entities go in the right entity chain.
1314
1315 -- We analyze with all checks suppressed (since we do
1316 -- not expect any exceptions).
1317
1318 Push_Scope (STJ.Ent);
1319 Analyze (Decl_ARECnT, Suppress => All_Checks);
1320
1321 -- Note that we need to call Set_Suppress_Initialization
1322 -- after Decl_ARECnT has been analyzed, but before
1323 -- analyzing Decl_ARECnP so that the flag is properly
1324 -- taking into account.
1325
1326 Set_Suppress_Initialization (STJ.ARECnT);
1327
1328 Analyze (Decl_ARECnPT, Suppress => All_Checks);
1329 Analyze (Decl_ARECn, Suppress => All_Checks);
1330 Analyze (Decl_ARECnP, Suppress => All_Checks);
1331
1332 if Present (Decl_Assign) then
1333 Analyze (Decl_Assign, Suppress => All_Checks);
1334 end if;
1335
1336 Pop_Scope;
1337
1338 -- Next step, for each uplevel referenced entity, add
1339 -- assignment operations to set the component in the
1340 -- activation record.
1341
1342 if Present (STJ.Uents) then
1343 declare
1344 Elmt : Elmt_Id;
1345
1346 begin
1347 Elmt := First_Elmt (STJ.Uents);
1348 while Present (Elmt) loop
1349 declare
1350 Ent : constant Entity_Id := Node (Elmt);
1351 Loc : constant Source_Ptr := Sloc (Ent);
1352 Dec : constant Node_Id :=
1353 Declaration_Node (Ent);
1354 Ins : Node_Id;
1355 Asn : Node_Id;
1356
1357 begin
1358 -- For parameters, we insert the assignment
1359 -- right after the declaration of ARECnP.
1360 -- For all other entities, we insert
1361 -- the assignment immediately after
1362 -- the declaration of the entity.
1363
1364 -- Note: we don't need to mark the entity
1365 -- as being aliased, because the address
1366 -- attribute will mark it as Address_Taken,
1367 -- and that is good enough.
1368
1369 if Is_Formal (Ent) then
1370 Ins := Decl_ARECnP;
1371 else
1372 Ins := Dec;
1373 end if;
1374
1375 -- Build and insert the assignment:
1376 -- ARECn.nam := nam'Address
1377
1378 Asn :=
1379 Make_Assignment_Statement (Loc,
1380 Name =>
1381 Make_Selected_Component (Loc,
1382 Prefix =>
1383 New_Occurrence_Of (STJ.ARECn, Loc),
1384 Selector_Name =>
1385 New_Occurrence_Of
1386 (Activation_Record_Component
1387 (Ent),
1388 Loc)),
1389
1390 Expression =>
1391 Make_Attribute_Reference (Loc,
1392 Prefix =>
1393 New_Occurrence_Of (Ent, Loc),
1394 Attribute_Name => Name_Address));
1395
1396 Insert_After (Ins, Asn);
1397
1398 -- Analyze the assignment statement. We do
1399 -- not need to establish the relevant scope
1400 -- stack entries here, because we have
1401 -- already set the correct entity references,
1402 -- so no name resolution is required, and no
1403 -- new entities are created, so we don't even
1404 -- need to set the current scope.
1405
1406 -- We analyze with all checks suppressed
1407 -- (since we do not expect any exceptions).
1408
1409 Analyze (Asn, Suppress => All_Checks);
1410 end;
1411
1412 Next_Elmt (Elmt);
1413 end loop;
1414 end;
1415 end if;
1416 end;
1417 end if;
1418 end;
1419 end loop;
1420 end Subp_Loop;
1421
1422 -- Next step, process uplevel references. This has to be done in a
1423 -- separate pass, after completing the processing in Sub_Loop because we
1424 -- need all the AREC declarations generated, inserted, and analyzed so
1425 -- that the uplevel references can be successfully analyzed.
1426
1427 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
1428 declare
1429 UPJ : Uref_Entry renames Urefs.Table (J);
1430
1431 begin
1432 -- Ignore type references, these are implicit references that do
1433 -- not need rewriting (e.g. the appearence in a conversion).
1434
1435 if Is_Type (UPJ.Ent) then
1436 goto Continue;
1437 end if;
1438
1439 -- Also ignore uplevel references to bounds of types that come
1440 -- from the original type reference.
1441
1442 if Is_Entity_Name (UPJ.Ref)
1443 and then Present (Entity (UPJ.Ref))
1444 and then Is_Type (Entity (UPJ.Ref))
1445 then
1446 goto Continue;
1447 end if;
1448
1449 -- Rewrite one reference
1450
1451 Rewrite_One_Ref : declare
1452 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
1453 -- Source location for the reference
1454
1455 Typ : constant Entity_Id := Etype (UPJ.Ent);
1456 -- The type of the referenced entity
1457
1458 Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref);
1459 -- The actual subtype of the reference
1460
1461 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
1462 -- Subp_Index for caller containing reference
1463
1464 STJR : Subp_Entry renames Subps.Table (RS_Caller);
1465 -- Subp_Entry for subprogram containing reference
1466
1467 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
1468 -- Subp_Index for subprogram containing referenced entity
1469
1470 STJE : Subp_Entry renames Subps.Table (RS_Callee);
1471 -- Subp_Entry for subprogram containing referenced entity
1472
1473 Pfx : Node_Id;
1474 Comp : Entity_Id;
1475 SI : SI_Type;
1476
1477 begin
1478 -- Ignore if no ARECnF entity for enclosing subprogram which
1479 -- probably happens as a result of not properly treating
1480 -- instance bodies. To be examined ???
1481
1482 -- If this test is omitted, then the compilation of freeze.adb
1483 -- and inline.adb fail in unnesting mode.
1484
1485 if No (STJR.ARECnF) then
1486 goto Continue;
1487 end if;
1488
1489 -- Push the current scope, so that the pointer type Tnn, and
1490 -- any subsidiary entities resulting from the analysis of the
1491 -- rewritten reference, go in the right entity chain.
1492
1493 Push_Scope (STJR.Ent);
1494
1495 -- Now we need to rewrite the reference. We have a reference
1496 -- from level STJR.Lev to level STJE.Lev. The general form of
1497 -- the rewritten reference for entity X is:
1498
1499 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
1500
1501 -- where a,b,c,d .. m =
1502 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
1503
1504 pragma Assert (STJR.Lev > STJE.Lev);
1505
1506 -- Compute the prefix of X. Here are examples to make things
1507 -- clear (with parens to show groupings, the prefix is
1508 -- everything except the .X at the end).
1509
1510 -- level 2 to level 1
1511
1512 -- AREC1F.X
1513
1514 -- level 3 to level 1
1515
1516 -- (AREC2F.AREC1U).X
1517
1518 -- level 4 to level 1
1519
1520 -- ((AREC3F.AREC2U).AREC1U).X
1521
1522 -- level 6 to level 2
1523
1524 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
1525
1526 -- In the above, ARECnF and ARECnU are pointers, so there are
1527 -- explicit dereferences required for these occurrences.
1528
1529 Pfx :=
1530 Make_Explicit_Dereference (Loc,
1531 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
1532 SI := RS_Caller;
1533 for L in STJE.Lev .. STJR.Lev - 2 loop
1534 SI := Enclosing_Subp (SI);
1535 Pfx :=
1536 Make_Explicit_Dereference (Loc,
1537 Prefix =>
1538 Make_Selected_Component (Loc,
1539 Prefix => Pfx,
1540 Selector_Name =>
1541 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
1542 end loop;
1543
1544 -- Get activation record component (must exist)
1545
1546 Comp := Activation_Record_Component (UPJ.Ent);
1547 pragma Assert (Present (Comp));
1548
1549 -- Do the replacement
1550
1551 Rewrite (UPJ.Ref,
1552 Make_Attribute_Reference (Loc,
1553 Prefix => New_Occurrence_Of (Atyp, Loc),
1554 Attribute_Name => Name_Deref,
1555 Expressions => New_List (
1556 Make_Selected_Component (Loc,
1557 Prefix => Pfx,
1558 Selector_Name =>
1559 New_Occurrence_Of (Comp, Loc)))));
1560
1561 -- Analyze and resolve the new expression. We do not need to
1562 -- establish the relevant scope stack entries here, because we
1563 -- have already set all the correct entity references, so no
1564 -- name resolution is needed. We have already set the current
1565 -- scope, so that any new entities created will be in the right
1566 -- scope.
1567
1568 -- We analyze with all checks suppressed (since we do not
1569 -- expect any exceptions)
1570
1571 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
1572 Pop_Scope;
1573 end Rewrite_One_Ref;
1574 end;
1575
1576 <<Continue>>
1577 null;
1578 end loop Uplev_Refs;
1579
1580 -- Finally, loop through all calls adding extra actual for the
1581 -- activation record where it is required.
1582
1583 Adjust_Calls : for J in Calls.First .. Calls.Last loop
1584
1585 -- Process a single call, we are only interested in a call to a
1586 -- subprogram that actually needs a pointer to an activation record,
1587 -- as indicated by the ARECnF entity being set. This excludes the
1588 -- top level subprogram, and any subprogram not having uplevel refs.
1589
1590 Adjust_One_Call : declare
1591 CTJ : Call_Entry renames Calls.Table (J);
1592 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
1593 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
1594
1595 Loc : constant Source_Ptr := Sloc (CTJ.N);
1596
1597 Extra : Node_Id;
1598 ExtraP : Node_Id;
1599 SubX : SI_Type;
1600 Act : Node_Id;
1601
1602 begin
1603 if Present (STT.ARECnF) then
1604
1605 -- CTJ.N is a call to a subprogram which may require a pointer
1606 -- to an activation record. The subprogram containing the call
1607 -- is CTJ.From and the subprogram being called is CTJ.To, so we
1608 -- have a call from level STF.Lev to level STT.Lev.
1609
1610 -- There are three possibilities:
1611
1612 -- For a call to the same level, we just pass the activation
1613 -- record passed to the calling subprogram.
1614
1615 if STF.Lev = STT.Lev then
1616 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1617
1618 -- For a call that goes down a level, we pass a pointer to the
1619 -- activation record constructed within the caller (which may
1620 -- be the outer-level subprogram, but also may be a more deeply
1621 -- nested caller).
1622
1623 elsif STT.Lev = STF.Lev + 1 then
1624 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
1625
1626 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
1627 -- since it is not possible to do a downcall of more than
1628 -- one level.
1629
1630 -- For a call from level STF.Lev to level STT.Lev, we
1631 -- have to find the activation record needed by the
1632 -- callee. This is as follows:
1633
1634 -- ARECaF.ARECbU.ARECcU....ARECm
1635
1636 -- where a,b,c .. m =
1637 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
1638
1639 else
1640 pragma Assert (STT.Lev < STF.Lev);
1641
1642 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
1643 SubX := Subp_Index (CTJ.Caller);
1644 for K in reverse STT.Lev .. STF.Lev - 1 loop
1645 SubX := Enclosing_Subp (SubX);
1646 Extra :=
1647 Make_Selected_Component (Loc,
1648 Prefix => Extra,
1649 Selector_Name =>
1650 New_Occurrence_Of
1651 (Subps.Table (SubX).ARECnU, Loc));
1652 end loop;
1653 end if;
1654
1655 -- Extra is the additional parameter to be added. Build a
1656 -- parameter association that we can append to the actuals.
1657
1658 ExtraP :=
1659 Make_Parameter_Association (Loc,
1660 Selector_Name =>
1661 New_Occurrence_Of (STT.ARECnF, Loc),
1662 Explicit_Actual_Parameter => Extra);
1663
1664 if No (Parameter_Associations (CTJ.N)) then
1665 Set_Parameter_Associations (CTJ.N, Empty_List);
1666 end if;
1667
1668 Append (ExtraP, Parameter_Associations (CTJ.N));
1669
1670 -- We need to deal with the actual parameter chain as well. The
1671 -- newly added parameter is always the last actual.
1672
1673 Act := First_Named_Actual (CTJ.N);
1674
1675 if No (Act) then
1676 Set_First_Named_Actual (CTJ.N, Extra);
1677
1678 -- Here we must follow the chain and append the new entry
1679
1680 else
1681 loop
1682 declare
1683 PAN : Node_Id;
1684 NNA : Node_Id;
1685
1686 begin
1687 PAN := Parent (Act);
1688 pragma Assert (Nkind (PAN) = N_Parameter_Association);
1689 NNA := Next_Named_Actual (PAN);
1690
1691 if No (NNA) then
1692 Set_Next_Named_Actual (PAN, Extra);
1693 exit;
1694 end if;
1695
1696 Act := NNA;
1697 end;
1698 end loop;
1699 end if;
1700
1701 -- Analyze and resolve the new actual. We do not need to
1702 -- establish the relevant scope stack entries here, because
1703 -- we have already set all the correct entity references, so
1704 -- no name resolution is needed.
1705
1706 -- We analyze with all checks suppressed (since we do not
1707 -- expect any exceptions, and also we temporarily turn off
1708 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
1709 -- references (not needed at this stage, and in fact causes
1710 -- a bit of recursive chaos).
1711
1712 Opt.Unnest_Subprogram_Mode := False;
1713 Analyze_And_Resolve
1714 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
1715 Opt.Unnest_Subprogram_Mode := True;
1716 end if;
1717 end Adjust_One_Call;
1718 end loop Adjust_Calls;
1719
1720 return;
1721 end Unnest_Subprogram;
1722
1723 ------------------------
1724 -- Unnest_Subprograms --
1725 ------------------------
1726
1727 procedure Unnest_Subprograms (N : Node_Id) is
1728 function Search_Subprograms (N : Node_Id) return Traverse_Result;
1729 -- Tree visitor that search for outer level procedures with nested
1730 -- subprograms and invokes Unnest_Subprogram()
1731
1732 ------------------------
1733 -- Search_Subprograms --
1734 ------------------------
1735
1736 function Search_Subprograms (N : Node_Id) return Traverse_Result is
1737 begin
1738 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
1739 declare
1740 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
1741
1742 begin
1743 -- We are only interested in subprograms (not generic
1744 -- subprograms), that have nested subprograms.
1745
1746 if Is_Subprogram (Spec_Id)
1747 and then Has_Nested_Subprogram (Spec_Id)
1748 and then Is_Library_Level_Entity (Spec_Id)
1749 then
1750 Unnest_Subprogram (Spec_Id, N);
1751 end if;
1752 end;
1753 end if;
1754
1755 return OK;
1756 end Search_Subprograms;
1757
1758 ---------------
1759 -- Do_Search --
1760 ---------------
1761
1762 procedure Do_Search is new Traverse_Proc (Search_Subprograms);
1763 -- Subtree visitor instantiation
1764
1765 -- Start of processing for Unnest_Subprograms
1766
1767 begin
1768 if not Opt.Unnest_Subprogram_Mode then
1769 return;
1770 end if;
1771
1772 Do_Search (N);
1773 end Unnest_Subprograms;
1774
1775 end Exp_Unst;