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