|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-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 Debug_A; use Debug_A;
|
|
|
29 with Elists; use Elists;
|
|
|
30 with Exp_SPARK; use Exp_SPARK;
|
|
|
31 with Expander; use Expander;
|
|
|
32 with Ghost; use Ghost;
|
|
|
33 with Lib; use Lib;
|
|
|
34 with Lib.Load; use Lib.Load;
|
|
|
35 with Nlists; use Nlists;
|
|
|
36 with Output; use Output;
|
|
|
37 with Restrict; use Restrict;
|
|
|
38 with Sem_Attr; use Sem_Attr;
|
|
|
39 with Sem_Ch2; use Sem_Ch2;
|
|
|
40 with Sem_Ch3; use Sem_Ch3;
|
|
|
41 with Sem_Ch4; use Sem_Ch4;
|
|
|
42 with Sem_Ch5; use Sem_Ch5;
|
|
|
43 with Sem_Ch6; use Sem_Ch6;
|
|
|
44 with Sem_Ch7; use Sem_Ch7;
|
|
|
45 with Sem_Ch8; use Sem_Ch8;
|
|
|
46 with Sem_Ch9; use Sem_Ch9;
|
|
|
47 with Sem_Ch10; use Sem_Ch10;
|
|
|
48 with Sem_Ch11; use Sem_Ch11;
|
|
|
49 with Sem_Ch12; use Sem_Ch12;
|
|
|
50 with Sem_Ch13; use Sem_Ch13;
|
|
|
51 with Sem_Prag; use Sem_Prag;
|
|
|
52 with Sem_Util; use Sem_Util;
|
|
|
53 with Sinfo; use Sinfo;
|
|
|
54 with Stand; use Stand;
|
|
|
55 with Stylesw; use Stylesw;
|
|
|
56 with Uintp; use Uintp;
|
|
|
57 with Uname; use Uname;
|
|
|
58
|
|
|
59 with Unchecked_Deallocation;
|
|
|
60
|
|
|
61 pragma Warnings (Off, Sem_Util);
|
|
|
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
|
|
|
63
|
|
|
64 package body Sem is
|
|
|
65
|
|
|
66 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
|
|
|
67 -- Controls debugging printouts for Walk_Library_Items
|
|
|
68
|
|
|
69 Outer_Generic_Scope : Entity_Id := Empty;
|
|
|
70 -- Global reference to the outer scope that is generic. In a non-generic
|
|
|
71 -- context, it is empty. At the moment, it is only used for avoiding
|
|
|
72 -- freezing of external references in generics.
|
|
|
73
|
|
|
74 Comp_Unit_List : Elist_Id := No_Elist;
|
|
|
75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
|
|
|
76 -- processed by Semantics, in an appropriate order. Initialized to
|
|
|
77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
|
|
|
78 -- to New_Elmt_List on first use.
|
|
|
79
|
|
|
80 generic
|
|
|
81 with procedure Action (Withed_Unit : Node_Id);
|
|
|
82 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
|
|
|
83 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
|
|
|
84 -- Ignore limited withs, unless Include_Limited is True. CU must be an
|
|
|
85 -- N_Compilation_Unit.
|
|
|
86
|
|
|
87 generic
|
|
|
88 with procedure Action (Withed_Unit : Node_Id);
|
|
|
89 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
|
|
|
90 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
|
|
|
91 -- of this unit, since they count as dependences on their parent library
|
|
|
92 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
|
|
|
93
|
|
|
94 -------------
|
|
|
95 -- Analyze --
|
|
|
96 -------------
|
|
|
97
|
|
|
98 -- WARNING: This routine manages Ghost regions. Return statements must be
|
|
|
99 -- replaced by gotos which jump to the end of the routine and restore the
|
|
|
100 -- Ghost mode.
|
|
|
101
|
|
|
102 procedure Analyze (N : Node_Id) is
|
|
131
|
103 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
|
104 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
|
105 -- Save the Ghost-related attributes to restore on exit
|
|
111
|
106
|
|
|
107 begin
|
|
|
108 Debug_A_Entry ("analyzing ", N);
|
|
|
109
|
|
|
110 -- Immediate return if already analyzed
|
|
|
111
|
|
|
112 if Analyzed (N) then
|
|
|
113 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
|
|
|
114 return;
|
|
|
115 end if;
|
|
|
116
|
|
|
117 -- A declaration may be subject to pragma Ghost. Set the mode now to
|
|
|
118 -- ensure that any nodes generated during analysis and expansion are
|
|
|
119 -- marked as Ghost.
|
|
|
120
|
|
|
121 if Is_Declaration (N) then
|
|
|
122 Mark_And_Set_Ghost_Declaration (N);
|
|
|
123 end if;
|
|
|
124
|
|
|
125 -- Otherwise processing depends on the node kind
|
|
|
126
|
|
|
127 case Nkind (N) is
|
|
|
128 when N_Abort_Statement =>
|
|
|
129 Analyze_Abort_Statement (N);
|
|
|
130
|
|
|
131 when N_Abstract_Subprogram_Declaration =>
|
|
|
132 Analyze_Abstract_Subprogram_Declaration (N);
|
|
|
133
|
|
|
134 when N_Accept_Alternative =>
|
|
|
135 Analyze_Accept_Alternative (N);
|
|
|
136
|
|
|
137 when N_Accept_Statement =>
|
|
|
138 Analyze_Accept_Statement (N);
|
|
|
139
|
|
|
140 when N_Aggregate =>
|
|
|
141 Analyze_Aggregate (N);
|
|
|
142
|
|
|
143 when N_Allocator =>
|
|
|
144 Analyze_Allocator (N);
|
|
|
145
|
|
|
146 when N_And_Then =>
|
|
|
147 Analyze_Short_Circuit (N);
|
|
|
148
|
|
|
149 when N_Assignment_Statement =>
|
|
|
150 Analyze_Assignment (N);
|
|
|
151
|
|
|
152 when N_Asynchronous_Select =>
|
|
|
153 Analyze_Asynchronous_Select (N);
|
|
|
154
|
|
|
155 when N_At_Clause =>
|
|
|
156 Analyze_At_Clause (N);
|
|
|
157
|
|
|
158 when N_Attribute_Reference =>
|
|
|
159 Analyze_Attribute (N);
|
|
|
160
|
|
|
161 when N_Attribute_Definition_Clause =>
|
|
|
162 Analyze_Attribute_Definition_Clause (N);
|
|
|
163
|
|
|
164 when N_Block_Statement =>
|
|
|
165 Analyze_Block_Statement (N);
|
|
|
166
|
|
|
167 when N_Case_Expression =>
|
|
|
168 Analyze_Case_Expression (N);
|
|
|
169
|
|
|
170 when N_Case_Statement =>
|
|
|
171 Analyze_Case_Statement (N);
|
|
|
172
|
|
|
173 when N_Character_Literal =>
|
|
|
174 Analyze_Character_Literal (N);
|
|
|
175
|
|
|
176 when N_Code_Statement =>
|
|
|
177 Analyze_Code_Statement (N);
|
|
|
178
|
|
|
179 when N_Compilation_Unit =>
|
|
|
180 Analyze_Compilation_Unit (N);
|
|
|
181
|
|
|
182 when N_Component_Declaration =>
|
|
|
183 Analyze_Component_Declaration (N);
|
|
|
184
|
|
|
185 when N_Compound_Statement =>
|
|
|
186 Analyze_Compound_Statement (N);
|
|
|
187
|
|
|
188 when N_Conditional_Entry_Call =>
|
|
|
189 Analyze_Conditional_Entry_Call (N);
|
|
|
190
|
|
|
191 when N_Delay_Alternative =>
|
|
|
192 Analyze_Delay_Alternative (N);
|
|
|
193
|
|
|
194 when N_Delay_Relative_Statement =>
|
|
|
195 Analyze_Delay_Relative (N);
|
|
|
196
|
|
|
197 when N_Delay_Until_Statement =>
|
|
|
198 Analyze_Delay_Until (N);
|
|
|
199
|
|
|
200 when N_Delta_Aggregate =>
|
|
|
201 Analyze_Aggregate (N);
|
|
|
202
|
|
|
203 when N_Entry_Body =>
|
|
|
204 Analyze_Entry_Body (N);
|
|
|
205
|
|
|
206 when N_Entry_Body_Formal_Part =>
|
|
|
207 Analyze_Entry_Body_Formal_Part (N);
|
|
|
208
|
|
|
209 when N_Entry_Call_Alternative =>
|
|
|
210 Analyze_Entry_Call_Alternative (N);
|
|
|
211
|
|
|
212 when N_Entry_Declaration =>
|
|
|
213 Analyze_Entry_Declaration (N);
|
|
|
214
|
|
|
215 when N_Entry_Index_Specification =>
|
|
|
216 Analyze_Entry_Index_Specification (N);
|
|
|
217
|
|
|
218 when N_Enumeration_Representation_Clause =>
|
|
|
219 Analyze_Enumeration_Representation_Clause (N);
|
|
|
220
|
|
|
221 when N_Exception_Declaration =>
|
|
|
222 Analyze_Exception_Declaration (N);
|
|
|
223
|
|
|
224 when N_Exception_Renaming_Declaration =>
|
|
|
225 Analyze_Exception_Renaming (N);
|
|
|
226
|
|
|
227 when N_Exit_Statement =>
|
|
|
228 Analyze_Exit_Statement (N);
|
|
|
229
|
|
|
230 when N_Expanded_Name =>
|
|
|
231 Analyze_Expanded_Name (N);
|
|
|
232
|
|
|
233 when N_Explicit_Dereference =>
|
|
|
234 Analyze_Explicit_Dereference (N);
|
|
|
235
|
|
|
236 when N_Expression_Function =>
|
|
|
237 Analyze_Expression_Function (N);
|
|
|
238
|
|
|
239 when N_Expression_With_Actions =>
|
|
|
240 Analyze_Expression_With_Actions (N);
|
|
|
241
|
|
|
242 when N_Extended_Return_Statement =>
|
|
|
243 Analyze_Extended_Return_Statement (N);
|
|
|
244
|
|
|
245 when N_Extension_Aggregate =>
|
|
|
246 Analyze_Aggregate (N);
|
|
|
247
|
|
|
248 when N_Formal_Object_Declaration =>
|
|
|
249 Analyze_Formal_Object_Declaration (N);
|
|
|
250
|
|
|
251 when N_Formal_Package_Declaration =>
|
|
|
252 Analyze_Formal_Package_Declaration (N);
|
|
|
253
|
|
|
254 when N_Formal_Subprogram_Declaration =>
|
|
|
255 Analyze_Formal_Subprogram_Declaration (N);
|
|
|
256
|
|
|
257 when N_Formal_Type_Declaration =>
|
|
|
258 Analyze_Formal_Type_Declaration (N);
|
|
|
259
|
|
|
260 when N_Free_Statement =>
|
|
|
261 Analyze_Free_Statement (N);
|
|
|
262
|
|
|
263 when N_Freeze_Entity =>
|
|
|
264 Analyze_Freeze_Entity (N);
|
|
|
265
|
|
|
266 when N_Freeze_Generic_Entity =>
|
|
|
267 Analyze_Freeze_Generic_Entity (N);
|
|
|
268
|
|
|
269 when N_Full_Type_Declaration =>
|
|
|
270 Analyze_Full_Type_Declaration (N);
|
|
|
271
|
|
|
272 when N_Function_Call =>
|
|
|
273 Analyze_Function_Call (N);
|
|
|
274
|
|
|
275 when N_Function_Instantiation =>
|
|
|
276 Analyze_Function_Instantiation (N);
|
|
|
277
|
|
|
278 when N_Generic_Function_Renaming_Declaration =>
|
|
|
279 Analyze_Generic_Function_Renaming (N);
|
|
|
280
|
|
|
281 when N_Generic_Package_Declaration =>
|
|
|
282 Analyze_Generic_Package_Declaration (N);
|
|
|
283
|
|
|
284 when N_Generic_Package_Renaming_Declaration =>
|
|
|
285 Analyze_Generic_Package_Renaming (N);
|
|
|
286
|
|
|
287 when N_Generic_Procedure_Renaming_Declaration =>
|
|
|
288 Analyze_Generic_Procedure_Renaming (N);
|
|
|
289
|
|
|
290 when N_Generic_Subprogram_Declaration =>
|
|
|
291 Analyze_Generic_Subprogram_Declaration (N);
|
|
|
292
|
|
|
293 when N_Goto_Statement =>
|
|
|
294 Analyze_Goto_Statement (N);
|
|
|
295
|
|
|
296 when N_Handled_Sequence_Of_Statements =>
|
|
|
297 Analyze_Handled_Statements (N);
|
|
|
298
|
|
|
299 when N_Identifier =>
|
|
|
300 Analyze_Identifier (N);
|
|
|
301
|
|
|
302 when N_If_Expression =>
|
|
|
303 Analyze_If_Expression (N);
|
|
|
304
|
|
|
305 when N_If_Statement =>
|
|
|
306 Analyze_If_Statement (N);
|
|
|
307
|
|
|
308 when N_Implicit_Label_Declaration =>
|
|
|
309 Analyze_Implicit_Label_Declaration (N);
|
|
|
310
|
|
|
311 when N_In =>
|
|
|
312 Analyze_Membership_Op (N);
|
|
|
313
|
|
|
314 when N_Incomplete_Type_Declaration =>
|
|
|
315 Analyze_Incomplete_Type_Decl (N);
|
|
|
316
|
|
|
317 when N_Indexed_Component =>
|
|
|
318 Analyze_Indexed_Component_Form (N);
|
|
|
319
|
|
|
320 when N_Integer_Literal =>
|
|
|
321 Analyze_Integer_Literal (N);
|
|
|
322
|
|
|
323 when N_Iterator_Specification =>
|
|
|
324 Analyze_Iterator_Specification (N);
|
|
|
325
|
|
|
326 when N_Itype_Reference =>
|
|
|
327 Analyze_Itype_Reference (N);
|
|
|
328
|
|
|
329 when N_Label =>
|
|
|
330 Analyze_Label (N);
|
|
|
331
|
|
|
332 when N_Loop_Parameter_Specification =>
|
|
|
333 Analyze_Loop_Parameter_Specification (N);
|
|
|
334
|
|
|
335 when N_Loop_Statement =>
|
|
|
336 Analyze_Loop_Statement (N);
|
|
|
337
|
|
|
338 when N_Not_In =>
|
|
|
339 Analyze_Membership_Op (N);
|
|
|
340
|
|
|
341 when N_Null =>
|
|
|
342 Analyze_Null (N);
|
|
|
343
|
|
|
344 when N_Null_Statement =>
|
|
|
345 Analyze_Null_Statement (N);
|
|
|
346
|
|
|
347 when N_Number_Declaration =>
|
|
|
348 Analyze_Number_Declaration (N);
|
|
|
349
|
|
|
350 when N_Object_Declaration =>
|
|
|
351 Analyze_Object_Declaration (N);
|
|
|
352
|
|
|
353 when N_Object_Renaming_Declaration =>
|
|
|
354 Analyze_Object_Renaming (N);
|
|
|
355
|
|
|
356 when N_Operator_Symbol =>
|
|
|
357 Analyze_Operator_Symbol (N);
|
|
|
358
|
|
|
359 when N_Op_Abs =>
|
|
|
360 Analyze_Unary_Op (N);
|
|
|
361
|
|
|
362 when N_Op_Add =>
|
|
|
363 Analyze_Arithmetic_Op (N);
|
|
|
364
|
|
|
365 when N_Op_And =>
|
|
|
366 Analyze_Logical_Op (N);
|
|
|
367
|
|
|
368 when N_Op_Concat =>
|
|
|
369 Analyze_Concatenation (N);
|
|
|
370
|
|
|
371 when N_Op_Divide =>
|
|
|
372 Analyze_Arithmetic_Op (N);
|
|
|
373
|
|
|
374 when N_Op_Eq =>
|
|
|
375 Analyze_Equality_Op (N);
|
|
|
376
|
|
|
377 when N_Op_Expon =>
|
|
|
378 Analyze_Arithmetic_Op (N);
|
|
|
379
|
|
|
380 when N_Op_Ge =>
|
|
|
381 Analyze_Comparison_Op (N);
|
|
|
382
|
|
|
383 when N_Op_Gt =>
|
|
|
384 Analyze_Comparison_Op (N);
|
|
|
385
|
|
|
386 when N_Op_Le =>
|
|
|
387 Analyze_Comparison_Op (N);
|
|
|
388
|
|
|
389 when N_Op_Lt =>
|
|
|
390 Analyze_Comparison_Op (N);
|
|
|
391
|
|
|
392 when N_Op_Minus =>
|
|
|
393 Analyze_Unary_Op (N);
|
|
|
394
|
|
|
395 when N_Op_Mod =>
|
|
|
396 Analyze_Mod (N);
|
|
|
397
|
|
|
398 when N_Op_Multiply =>
|
|
|
399 Analyze_Arithmetic_Op (N);
|
|
|
400
|
|
|
401 when N_Op_Ne =>
|
|
|
402 Analyze_Equality_Op (N);
|
|
|
403
|
|
|
404 when N_Op_Not =>
|
|
|
405 Analyze_Negation (N);
|
|
|
406
|
|
|
407 when N_Op_Or =>
|
|
|
408 Analyze_Logical_Op (N);
|
|
|
409
|
|
|
410 when N_Op_Plus =>
|
|
|
411 Analyze_Unary_Op (N);
|
|
|
412
|
|
|
413 when N_Op_Rem =>
|
|
|
414 Analyze_Arithmetic_Op (N);
|
|
|
415
|
|
|
416 when N_Op_Rotate_Left =>
|
|
|
417 Analyze_Arithmetic_Op (N);
|
|
|
418
|
|
|
419 when N_Op_Rotate_Right =>
|
|
|
420 Analyze_Arithmetic_Op (N);
|
|
|
421
|
|
|
422 when N_Op_Shift_Left =>
|
|
|
423 Analyze_Arithmetic_Op (N);
|
|
|
424
|
|
|
425 when N_Op_Shift_Right =>
|
|
|
426 Analyze_Arithmetic_Op (N);
|
|
|
427
|
|
|
428 when N_Op_Shift_Right_Arithmetic =>
|
|
|
429 Analyze_Arithmetic_Op (N);
|
|
|
430
|
|
|
431 when N_Op_Subtract =>
|
|
|
432 Analyze_Arithmetic_Op (N);
|
|
|
433
|
|
|
434 when N_Op_Xor =>
|
|
|
435 Analyze_Logical_Op (N);
|
|
|
436
|
|
|
437 when N_Or_Else =>
|
|
|
438 Analyze_Short_Circuit (N);
|
|
|
439
|
|
|
440 when N_Others_Choice =>
|
|
|
441 Analyze_Others_Choice (N);
|
|
|
442
|
|
|
443 when N_Package_Body =>
|
|
|
444 Analyze_Package_Body (N);
|
|
|
445
|
|
|
446 when N_Package_Body_Stub =>
|
|
|
447 Analyze_Package_Body_Stub (N);
|
|
|
448
|
|
|
449 when N_Package_Declaration =>
|
|
|
450 Analyze_Package_Declaration (N);
|
|
|
451
|
|
|
452 when N_Package_Instantiation =>
|
|
|
453 Analyze_Package_Instantiation (N);
|
|
|
454
|
|
|
455 when N_Package_Renaming_Declaration =>
|
|
|
456 Analyze_Package_Renaming (N);
|
|
|
457
|
|
|
458 when N_Package_Specification =>
|
|
|
459 Analyze_Package_Specification (N);
|
|
|
460
|
|
|
461 when N_Parameter_Association =>
|
|
|
462 Analyze_Parameter_Association (N);
|
|
|
463
|
|
|
464 when N_Pragma =>
|
|
|
465 Analyze_Pragma (N);
|
|
|
466
|
|
|
467 when N_Private_Extension_Declaration =>
|
|
|
468 Analyze_Private_Extension_Declaration (N);
|
|
|
469
|
|
|
470 when N_Private_Type_Declaration =>
|
|
|
471 Analyze_Private_Type_Declaration (N);
|
|
|
472
|
|
|
473 when N_Procedure_Call_Statement =>
|
|
|
474 Analyze_Procedure_Call (N);
|
|
|
475
|
|
|
476 when N_Procedure_Instantiation =>
|
|
|
477 Analyze_Procedure_Instantiation (N);
|
|
|
478
|
|
|
479 when N_Protected_Body =>
|
|
|
480 Analyze_Protected_Body (N);
|
|
|
481
|
|
|
482 when N_Protected_Body_Stub =>
|
|
|
483 Analyze_Protected_Body_Stub (N);
|
|
|
484
|
|
|
485 when N_Protected_Definition =>
|
|
|
486 Analyze_Protected_Definition (N);
|
|
|
487
|
|
|
488 when N_Protected_Type_Declaration =>
|
|
|
489 Analyze_Protected_Type_Declaration (N);
|
|
|
490
|
|
|
491 when N_Qualified_Expression =>
|
|
|
492 Analyze_Qualified_Expression (N);
|
|
|
493
|
|
|
494 when N_Quantified_Expression =>
|
|
|
495 Analyze_Quantified_Expression (N);
|
|
|
496
|
|
|
497 when N_Raise_Expression =>
|
|
|
498 Analyze_Raise_Expression (N);
|
|
|
499
|
|
|
500 when N_Raise_Statement =>
|
|
|
501 Analyze_Raise_Statement (N);
|
|
|
502
|
|
|
503 when N_Raise_xxx_Error =>
|
|
|
504 Analyze_Raise_xxx_Error (N);
|
|
|
505
|
|
|
506 when N_Range =>
|
|
|
507 Analyze_Range (N);
|
|
|
508
|
|
|
509 when N_Range_Constraint =>
|
|
|
510 Analyze_Range (Range_Expression (N));
|
|
|
511
|
|
|
512 when N_Real_Literal =>
|
|
|
513 Analyze_Real_Literal (N);
|
|
|
514
|
|
|
515 when N_Record_Representation_Clause =>
|
|
|
516 Analyze_Record_Representation_Clause (N);
|
|
|
517
|
|
|
518 when N_Reference =>
|
|
|
519 Analyze_Reference (N);
|
|
|
520
|
|
|
521 when N_Requeue_Statement =>
|
|
|
522 Analyze_Requeue (N);
|
|
|
523
|
|
|
524 when N_Simple_Return_Statement =>
|
|
|
525 Analyze_Simple_Return_Statement (N);
|
|
|
526
|
|
|
527 when N_Selected_Component =>
|
|
|
528 Find_Selected_Component (N);
|
|
|
529 -- ??? why not Analyze_Selected_Component, needs comments
|
|
|
530
|
|
|
531 when N_Selective_Accept =>
|
|
|
532 Analyze_Selective_Accept (N);
|
|
|
533
|
|
|
534 when N_Single_Protected_Declaration =>
|
|
|
535 Analyze_Single_Protected_Declaration (N);
|
|
|
536
|
|
|
537 when N_Single_Task_Declaration =>
|
|
|
538 Analyze_Single_Task_Declaration (N);
|
|
|
539
|
|
|
540 when N_Slice =>
|
|
|
541 Analyze_Slice (N);
|
|
|
542
|
|
|
543 when N_String_Literal =>
|
|
|
544 Analyze_String_Literal (N);
|
|
|
545
|
|
|
546 when N_Subprogram_Body =>
|
|
|
547 Analyze_Subprogram_Body (N);
|
|
|
548
|
|
|
549 when N_Subprogram_Body_Stub =>
|
|
|
550 Analyze_Subprogram_Body_Stub (N);
|
|
|
551
|
|
|
552 when N_Subprogram_Declaration =>
|
|
|
553 Analyze_Subprogram_Declaration (N);
|
|
|
554
|
|
|
555 when N_Subprogram_Renaming_Declaration =>
|
|
|
556 Analyze_Subprogram_Renaming (N);
|
|
|
557
|
|
|
558 when N_Subtype_Declaration =>
|
|
|
559 Analyze_Subtype_Declaration (N);
|
|
|
560
|
|
|
561 when N_Subtype_Indication =>
|
|
|
562 Analyze_Subtype_Indication (N);
|
|
|
563
|
|
|
564 when N_Subunit =>
|
|
|
565 Analyze_Subunit (N);
|
|
|
566
|
|
|
567 when N_Target_Name =>
|
|
|
568 Analyze_Target_Name (N);
|
|
|
569
|
|
|
570 when N_Task_Body =>
|
|
|
571 Analyze_Task_Body (N);
|
|
|
572
|
|
|
573 when N_Task_Body_Stub =>
|
|
|
574 Analyze_Task_Body_Stub (N);
|
|
|
575
|
|
|
576 when N_Task_Definition =>
|
|
|
577 Analyze_Task_Definition (N);
|
|
|
578
|
|
|
579 when N_Task_Type_Declaration =>
|
|
|
580 Analyze_Task_Type_Declaration (N);
|
|
|
581
|
|
|
582 when N_Terminate_Alternative =>
|
|
|
583 Analyze_Terminate_Alternative (N);
|
|
|
584
|
|
|
585 when N_Timed_Entry_Call =>
|
|
|
586 Analyze_Timed_Entry_Call (N);
|
|
|
587
|
|
|
588 when N_Triggering_Alternative =>
|
|
|
589 Analyze_Triggering_Alternative (N);
|
|
|
590
|
|
|
591 when N_Type_Conversion =>
|
|
|
592 Analyze_Type_Conversion (N);
|
|
|
593
|
|
|
594 when N_Unchecked_Expression =>
|
|
|
595 Analyze_Unchecked_Expression (N);
|
|
|
596
|
|
|
597 when N_Unchecked_Type_Conversion =>
|
|
|
598 Analyze_Unchecked_Type_Conversion (N);
|
|
|
599
|
|
|
600 when N_Use_Package_Clause =>
|
|
|
601 Analyze_Use_Package (N);
|
|
|
602
|
|
|
603 when N_Use_Type_Clause =>
|
|
|
604 Analyze_Use_Type (N);
|
|
|
605
|
|
|
606 when N_Validate_Unchecked_Conversion =>
|
|
|
607 null;
|
|
|
608
|
|
|
609 when N_Variant_Part =>
|
|
|
610 Analyze_Variant_Part (N);
|
|
|
611
|
|
|
612 when N_With_Clause =>
|
|
|
613 Analyze_With_Clause (N);
|
|
|
614
|
|
131
|
615 -- A call to analyze a marker is ignored because the node does not
|
|
|
616 -- have any static and run-time semantics.
|
|
|
617
|
|
|
618 when N_Call_Marker
|
|
|
619 | N_Variable_Reference_Marker
|
|
|
620 =>
|
|
111
|
621 null;
|
|
|
622
|
|
|
623 -- A call to analyze the Empty node is an error, but most likely it
|
|
|
624 -- is an error caused by an attempt to analyze a malformed piece of
|
|
|
625 -- tree caused by some other error, so if there have been any other
|
|
|
626 -- errors, we just ignore it, otherwise it is a real internal error
|
|
|
627 -- which we complain about.
|
|
|
628
|
|
|
629 -- We must also consider the case of call to a runtime function that
|
|
|
630 -- is not available in the configurable runtime.
|
|
|
631
|
|
|
632 when N_Empty =>
|
|
|
633 pragma Assert (Serious_Errors_Detected /= 0
|
|
|
634 or else Configurable_Run_Time_Violations /= 0);
|
|
|
635 null;
|
|
|
636
|
|
|
637 -- A call to analyze the error node is simply ignored, to avoid
|
|
|
638 -- causing cascaded errors (happens of course only in error cases)
|
|
|
639 -- Disable expansion in case it is still enabled, to prevent other
|
|
|
640 -- subsequent compiler glitches.
|
|
|
641
|
|
|
642 when N_Error =>
|
|
|
643 Expander_Mode_Save_And_Set (False);
|
|
|
644 null;
|
|
|
645
|
|
|
646 -- Push/Pop nodes normally don't come through an analyze call. An
|
|
|
647 -- exception is the dummy ones bracketing a subprogram body. In any
|
|
|
648 -- case there is nothing to be done to analyze such nodes.
|
|
|
649
|
|
|
650 when N_Push_Pop_xxx_Label =>
|
|
|
651 null;
|
|
|
652
|
|
|
653 -- SCIL nodes don't need analysis because they are decorated when
|
|
|
654 -- they are built. They are added to the tree by Insert_Actions and
|
|
|
655 -- the call to analyze them is generated when the full list is
|
|
|
656 -- analyzed.
|
|
|
657
|
|
|
658 when N_SCIL_Dispatch_Table_Tag_Init
|
|
|
659 | N_SCIL_Dispatching_Call
|
|
|
660 | N_SCIL_Membership_Test
|
|
|
661 =>
|
|
|
662 null;
|
|
|
663
|
|
|
664 -- A quantified expression with a missing "all" or "some" qualifier
|
|
|
665 -- looks identical to an iterated component association. By language
|
|
|
666 -- definition, the latter must be present within array aggregates. If
|
|
|
667 -- this is not the case, then the iterated component association is
|
|
|
668 -- really an illegal quantified expression. Diagnose this scenario.
|
|
|
669
|
|
|
670 when N_Iterated_Component_Association =>
|
|
|
671 Diagnose_Iterated_Component_Association (N);
|
|
|
672
|
|
|
673 -- For the remaining node types, we generate compiler abort, because
|
|
|
674 -- these nodes are always analyzed within the Sem_Chn routines and
|
|
|
675 -- there should never be a case of making a call to the main Analyze
|
|
|
676 -- routine for these node kinds. For example, an N_Access_Definition
|
|
|
677 -- node appears only in the context of a type declaration, and is
|
|
|
678 -- processed by the analyze routine for type declarations.
|
|
|
679
|
|
|
680 when N_Abortable_Part
|
|
|
681 | N_Access_Definition
|
|
|
682 | N_Access_Function_Definition
|
|
|
683 | N_Access_Procedure_Definition
|
|
|
684 | N_Access_To_Object_Definition
|
|
|
685 | N_Aspect_Specification
|
|
|
686 | N_Case_Expression_Alternative
|
|
|
687 | N_Case_Statement_Alternative
|
|
|
688 | N_Compilation_Unit_Aux
|
|
|
689 | N_Component_Association
|
|
|
690 | N_Component_Clause
|
|
|
691 | N_Component_Definition
|
|
|
692 | N_Component_List
|
|
|
693 | N_Constrained_Array_Definition
|
|
|
694 | N_Contract
|
|
|
695 | N_Decimal_Fixed_Point_Definition
|
|
|
696 | N_Defining_Character_Literal
|
|
|
697 | N_Defining_Identifier
|
|
|
698 | N_Defining_Operator_Symbol
|
|
|
699 | N_Defining_Program_Unit_Name
|
|
|
700 | N_Delta_Constraint
|
|
|
701 | N_Derived_Type_Definition
|
|
|
702 | N_Designator
|
|
|
703 | N_Digits_Constraint
|
|
|
704 | N_Discriminant_Association
|
|
|
705 | N_Discriminant_Specification
|
|
|
706 | N_Elsif_Part
|
|
|
707 | N_Entry_Call_Statement
|
|
|
708 | N_Enumeration_Type_Definition
|
|
|
709 | N_Exception_Handler
|
|
|
710 | N_Floating_Point_Definition
|
|
|
711 | N_Formal_Decimal_Fixed_Point_Definition
|
|
|
712 | N_Formal_Derived_Type_Definition
|
|
|
713 | N_Formal_Discrete_Type_Definition
|
|
|
714 | N_Formal_Floating_Point_Definition
|
|
|
715 | N_Formal_Modular_Type_Definition
|
|
|
716 | N_Formal_Ordinary_Fixed_Point_Definition
|
|
|
717 | N_Formal_Private_Type_Definition
|
|
|
718 | N_Formal_Incomplete_Type_Definition
|
|
|
719 | N_Formal_Signed_Integer_Type_Definition
|
|
|
720 | N_Function_Specification
|
|
|
721 | N_Generic_Association
|
|
|
722 | N_Index_Or_Discriminant_Constraint
|
|
|
723 | N_Iteration_Scheme
|
|
|
724 | N_Mod_Clause
|
|
|
725 | N_Modular_Type_Definition
|
|
|
726 | N_Ordinary_Fixed_Point_Definition
|
|
|
727 | N_Parameter_Specification
|
|
|
728 | N_Pragma_Argument_Association
|
|
|
729 | N_Procedure_Specification
|
|
|
730 | N_Real_Range_Specification
|
|
|
731 | N_Record_Definition
|
|
|
732 | N_Signed_Integer_Type_Definition
|
|
|
733 | N_Unconstrained_Array_Definition
|
|
|
734 | N_Unused_At_End
|
|
|
735 | N_Unused_At_Start
|
|
|
736 | N_Variant
|
|
|
737 =>
|
|
|
738 raise Program_Error;
|
|
|
739 end case;
|
|
|
740
|
|
|
741 Debug_A_Exit ("analyzing ", N, " (done)");
|
|
|
742
|
|
131
|
743 -- Mark relevant use-type and use-package clauses as effective
|
|
|
744 -- preferring the original node over the analyzed one in the case that
|
|
|
745 -- constant folding has occurred and removed references that need to be
|
|
|
746 -- examined. Also, if the node in question is overloaded then this is
|
|
|
747 -- deferred until resolution.
|
|
|
748
|
|
|
749 declare
|
|
|
750 Operat : Node_Id := Empty;
|
|
|
751 begin
|
|
|
752 -- Attempt to obtain a checkable operator node
|
|
|
753
|
|
|
754 if Nkind (Original_Node (N)) in N_Op then
|
|
|
755 Operat := Original_Node (N);
|
|
|
756 elsif Nkind (N) in N_Op then
|
|
|
757 Operat := N;
|
|
|
758 end if;
|
|
|
759
|
|
|
760 -- Mark the operator
|
|
|
761
|
|
|
762 if Present (Operat)
|
|
|
763 and then Present (Entity (Operat))
|
|
|
764 and then not Is_Overloaded (Operat)
|
|
|
765 then
|
|
|
766 Mark_Use_Clauses (Operat);
|
|
|
767 end if;
|
|
|
768 end;
|
|
111
|
769
|
|
|
770 -- Now that we have analyzed the node, we call the expander to perform
|
|
|
771 -- possible expansion. We skip this for subexpressions, because we don't
|
|
|
772 -- have the type yet, and the expander will need to know the type before
|
|
|
773 -- it can do its job. For subexpression nodes, the call to the expander
|
|
|
774 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
|
|
|
775 -- which can appear in a statement context, and needs expanding now in
|
|
|
776 -- the case (distinguished by Etype, as documented in Sinfo).
|
|
|
777
|
|
|
778 -- The Analyzed flag is also set at this point for non-subexpression
|
|
|
779 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
|
|
|
780 -- since resolution and expansion have not yet been completed). Note
|
|
|
781 -- that for N_Raise_xxx_Error we have to distinguish the expression
|
|
|
782 -- case from the statement case.
|
|
|
783
|
|
|
784 if Nkind (N) not in N_Subexpr
|
|
|
785 or else (Nkind (N) in N_Raise_xxx_Error
|
|
|
786 and then Etype (N) = Standard_Void_Type)
|
|
|
787 then
|
|
|
788 Expand (N);
|
|
|
789
|
|
|
790 -- Replace a reference to a renaming with the renamed object for SPARK.
|
|
|
791 -- In general this modification is performed by Expand_SPARK, however
|
|
|
792 -- certain constructs may not reach the resolution or expansion phase
|
|
|
793 -- and thus remain unchanged. The replacement is not performed when the
|
|
|
794 -- construct is overloaded as resolution must first take place. This is
|
|
|
795 -- also not done when analyzing a generic to preserve the original tree
|
|
|
796 -- and because the reference may become overloaded in the instance.
|
|
|
797
|
|
|
798 elsif GNATprove_Mode
|
|
|
799 and then Nkind_In (N, N_Expanded_Name, N_Identifier)
|
|
|
800 and then not Is_Overloaded (N)
|
|
|
801 and then not Inside_A_Generic
|
|
|
802 then
|
|
|
803 Expand_SPARK_Potential_Renaming (N);
|
|
|
804 end if;
|
|
|
805
|
|
131
|
806 Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
111
|
807 end Analyze;
|
|
|
808
|
|
|
809 -- Version with check(s) suppressed
|
|
|
810
|
|
|
811 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
|
|
|
812 begin
|
|
|
813 if Suppress = All_Checks then
|
|
|
814 declare
|
|
|
815 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
|
|
|
816 begin
|
|
|
817 Scope_Suppress.Suppress := (others => True);
|
|
|
818 Analyze (N);
|
|
|
819 Scope_Suppress.Suppress := Svs;
|
|
|
820 end;
|
|
|
821
|
|
|
822 elsif Suppress = Overflow_Check then
|
|
|
823 declare
|
|
|
824 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
|
|
|
825 begin
|
|
|
826 Scope_Suppress.Suppress (Suppress) := True;
|
|
|
827 Analyze (N);
|
|
|
828 Scope_Suppress.Suppress (Suppress) := Svg;
|
|
|
829 end;
|
|
|
830 end if;
|
|
|
831 end Analyze;
|
|
|
832
|
|
|
833 ------------------
|
|
|
834 -- Analyze_List --
|
|
|
835 ------------------
|
|
|
836
|
|
|
837 procedure Analyze_List (L : List_Id) is
|
|
|
838 Node : Node_Id;
|
|
|
839
|
|
|
840 begin
|
|
|
841 Node := First (L);
|
|
|
842 while Present (Node) loop
|
|
|
843 Analyze (Node);
|
|
|
844 Next (Node);
|
|
|
845 end loop;
|
|
|
846 end Analyze_List;
|
|
|
847
|
|
|
848 -- Version with check(s) suppressed
|
|
|
849
|
|
|
850 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
|
|
|
851 begin
|
|
|
852 if Suppress = All_Checks then
|
|
|
853 declare
|
|
|
854 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
|
|
|
855 begin
|
|
|
856 Scope_Suppress.Suppress := (others => True);
|
|
|
857 Analyze_List (L);
|
|
|
858 Scope_Suppress.Suppress := Svs;
|
|
|
859 end;
|
|
|
860
|
|
|
861 else
|
|
|
862 declare
|
|
|
863 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
|
|
|
864 begin
|
|
|
865 Scope_Suppress.Suppress (Suppress) := True;
|
|
|
866 Analyze_List (L);
|
|
|
867 Scope_Suppress.Suppress (Suppress) := Svg;
|
|
|
868 end;
|
|
|
869 end if;
|
|
|
870 end Analyze_List;
|
|
|
871
|
|
|
872 --------------------------
|
|
|
873 -- Copy_Suppress_Status --
|
|
|
874 --------------------------
|
|
|
875
|
|
|
876 procedure Copy_Suppress_Status
|
|
|
877 (C : Check_Id;
|
|
|
878 From : Entity_Id;
|
|
|
879 To : Entity_Id)
|
|
|
880 is
|
|
|
881 Found : Boolean;
|
|
|
882 pragma Warnings (Off, Found);
|
|
|
883
|
|
|
884 procedure Search_Stack
|
|
|
885 (Top : Suppress_Stack_Entry_Ptr;
|
|
|
886 Found : out Boolean);
|
|
|
887 -- Search given suppress stack for matching entry for entity. If found
|
|
|
888 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
|
|
|
889 -- entry for To onto the local suppress stack.
|
|
|
890
|
|
|
891 ------------------
|
|
|
892 -- Search_Stack --
|
|
|
893 ------------------
|
|
|
894
|
|
|
895 procedure Search_Stack
|
|
|
896 (Top : Suppress_Stack_Entry_Ptr;
|
|
|
897 Found : out Boolean)
|
|
|
898 is
|
|
|
899 Ptr : Suppress_Stack_Entry_Ptr;
|
|
|
900
|
|
|
901 begin
|
|
|
902 Ptr := Top;
|
|
|
903 while Ptr /= null loop
|
|
|
904 if Ptr.Entity = From
|
|
|
905 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
|
|
|
906 then
|
|
|
907 if Ptr.Suppress then
|
|
|
908 Set_Checks_May_Be_Suppressed (To, True);
|
|
|
909 Push_Local_Suppress_Stack_Entry
|
|
|
910 (Entity => To,
|
|
|
911 Check => C,
|
|
|
912 Suppress => True);
|
|
|
913 Found := True;
|
|
|
914 return;
|
|
|
915 end if;
|
|
|
916 end if;
|
|
|
917
|
|
|
918 Ptr := Ptr.Prev;
|
|
|
919 end loop;
|
|
|
920
|
|
|
921 Found := False;
|
|
|
922 return;
|
|
|
923 end Search_Stack;
|
|
|
924
|
|
|
925 -- Start of processing for Copy_Suppress_Status
|
|
|
926
|
|
|
927 begin
|
|
|
928 if not Checks_May_Be_Suppressed (From) then
|
|
|
929 return;
|
|
|
930 end if;
|
|
|
931
|
|
|
932 -- First search the global entity suppress table for a matching entry.
|
|
|
933 -- We also search this in reverse order so that if there are multiple
|
|
|
934 -- pragmas for the same entity, the last one applies.
|
|
|
935
|
|
|
936 Search_Stack (Global_Suppress_Stack_Top, Found);
|
|
|
937
|
|
|
938 if Found then
|
|
|
939 return;
|
|
|
940 end if;
|
|
|
941
|
|
|
942 -- Now search the local entity suppress stack, we search this in
|
|
|
943 -- reverse order so that we get the innermost entry that applies to
|
|
|
944 -- this case if there are nested entries. Note that for the purpose
|
|
|
945 -- of this procedure we are ONLY looking for entries corresponding
|
|
|
946 -- to a two-argument Suppress, where the second argument matches From.
|
|
|
947
|
|
|
948 Search_Stack (Local_Suppress_Stack_Top, Found);
|
|
|
949 end Copy_Suppress_Status;
|
|
|
950
|
|
|
951 -------------------------
|
|
|
952 -- Enter_Generic_Scope --
|
|
|
953 -------------------------
|
|
|
954
|
|
|
955 procedure Enter_Generic_Scope (S : Entity_Id) is
|
|
|
956 begin
|
|
|
957 if No (Outer_Generic_Scope) then
|
|
|
958 Outer_Generic_Scope := S;
|
|
|
959 end if;
|
|
|
960 end Enter_Generic_Scope;
|
|
|
961
|
|
|
962 ------------------------
|
|
|
963 -- Exit_Generic_Scope --
|
|
|
964 ------------------------
|
|
|
965
|
|
|
966 procedure Exit_Generic_Scope (S : Entity_Id) is
|
|
|
967 begin
|
|
|
968 if S = Outer_Generic_Scope then
|
|
|
969 Outer_Generic_Scope := Empty;
|
|
|
970 end if;
|
|
|
971 end Exit_Generic_Scope;
|
|
|
972
|
|
|
973 -----------------------
|
|
|
974 -- Explicit_Suppress --
|
|
|
975 -----------------------
|
|
|
976
|
|
|
977 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
|
|
|
978 Ptr : Suppress_Stack_Entry_Ptr;
|
|
|
979
|
|
|
980 begin
|
|
|
981 if not Checks_May_Be_Suppressed (E) then
|
|
|
982 return False;
|
|
|
983
|
|
|
984 else
|
|
|
985 Ptr := Global_Suppress_Stack_Top;
|
|
|
986 while Ptr /= null loop
|
|
|
987 if Ptr.Entity = E
|
|
|
988 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
|
|
|
989 then
|
|
|
990 return Ptr.Suppress;
|
|
|
991 end if;
|
|
|
992
|
|
|
993 Ptr := Ptr.Prev;
|
|
|
994 end loop;
|
|
|
995 end if;
|
|
|
996
|
|
|
997 return False;
|
|
|
998 end Explicit_Suppress;
|
|
|
999
|
|
|
1000 -----------------------------
|
|
|
1001 -- External_Ref_In_Generic --
|
|
|
1002 -----------------------------
|
|
|
1003
|
|
|
1004 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
|
|
|
1005 Scop : Entity_Id;
|
|
|
1006
|
|
|
1007 begin
|
|
|
1008 -- Entity is global if defined outside of current outer_generic_scope:
|
|
|
1009 -- Either the entity has a smaller depth that the outer generic, or it
|
|
|
1010 -- is in a different compilation unit, or it is defined within a unit
|
|
|
1011 -- in the same compilation, that is not within the outer_generic.
|
|
|
1012
|
|
|
1013 if No (Outer_Generic_Scope) then
|
|
|
1014 return False;
|
|
|
1015
|
|
|
1016 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
|
|
|
1017 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
|
|
|
1018 then
|
|
|
1019 return True;
|
|
|
1020
|
|
|
1021 else
|
|
|
1022 Scop := Scope (E);
|
|
|
1023 while Present (Scop) loop
|
|
|
1024 if Scop = Outer_Generic_Scope then
|
|
|
1025 return False;
|
|
|
1026 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
|
|
|
1027 return True;
|
|
|
1028 else
|
|
|
1029 Scop := Scope (Scop);
|
|
|
1030 end if;
|
|
|
1031 end loop;
|
|
|
1032
|
|
|
1033 return True;
|
|
|
1034 end if;
|
|
|
1035 end External_Ref_In_Generic;
|
|
|
1036
|
|
|
1037 ----------------
|
|
|
1038 -- Initialize --
|
|
|
1039 ----------------
|
|
|
1040
|
|
|
1041 procedure Initialize is
|
|
|
1042 Next : Suppress_Stack_Entry_Ptr;
|
|
|
1043
|
|
|
1044 procedure Free is new Unchecked_Deallocation
|
|
|
1045 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
|
|
|
1046
|
|
|
1047 begin
|
|
|
1048 -- Free any global suppress stack entries from a previous invocation
|
|
|
1049 -- of the compiler (in the normal case this loop does nothing).
|
|
|
1050
|
|
|
1051 while Suppress_Stack_Entries /= null loop
|
|
|
1052 Next := Suppress_Stack_Entries.Next;
|
|
|
1053 Free (Suppress_Stack_Entries);
|
|
|
1054 Suppress_Stack_Entries := Next;
|
|
|
1055 end loop;
|
|
|
1056
|
|
|
1057 Local_Suppress_Stack_Top := null;
|
|
|
1058 Global_Suppress_Stack_Top := null;
|
|
|
1059
|
|
|
1060 -- Clear scope stack, and reset global variables
|
|
|
1061
|
|
|
1062 Scope_Stack.Init;
|
|
|
1063 Unloaded_Subunits := False;
|
|
|
1064 end Initialize;
|
|
|
1065
|
|
|
1066 ------------------------------
|
|
|
1067 -- Insert_After_And_Analyze --
|
|
|
1068 ------------------------------
|
|
|
1069
|
|
|
1070 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
|
|
|
1071 Node : Node_Id;
|
|
|
1072
|
|
|
1073 begin
|
|
|
1074 if Present (M) then
|
|
|
1075
|
|
|
1076 -- If we are not at the end of the list, then the easiest
|
|
|
1077 -- coding is simply to insert before our successor.
|
|
|
1078
|
|
|
1079 if Present (Next (N)) then
|
|
|
1080 Insert_Before_And_Analyze (Next (N), M);
|
|
|
1081
|
|
|
1082 -- Case of inserting at the end of the list
|
|
|
1083
|
|
|
1084 else
|
|
|
1085 -- Capture the Node_Id of the node to be inserted. This Node_Id
|
|
|
1086 -- will still be the same after the insert operation.
|
|
|
1087
|
|
|
1088 Node := M;
|
|
|
1089 Insert_After (N, M);
|
|
|
1090
|
|
|
1091 -- Now just analyze from the inserted node to the end of
|
|
|
1092 -- the new list (note that this properly handles the case
|
|
|
1093 -- where any of the analyze calls result in the insertion of
|
|
|
1094 -- nodes after the analyzed node, expecting analysis).
|
|
|
1095
|
|
|
1096 while Present (Node) loop
|
|
|
1097 Analyze (Node);
|
|
|
1098 Mark_Rewrite_Insertion (Node);
|
|
|
1099 Next (Node);
|
|
|
1100 end loop;
|
|
|
1101 end if;
|
|
|
1102 end if;
|
|
|
1103 end Insert_After_And_Analyze;
|
|
|
1104
|
|
|
1105 -- Version with check(s) suppressed
|
|
|
1106
|
|
|
1107 procedure Insert_After_And_Analyze
|
|
|
1108 (N : Node_Id;
|
|
|
1109 M : Node_Id;
|
|
|
1110 Suppress : Check_Id)
|
|
|
1111 is
|
|
|
1112 begin
|
|
|
1113 if Suppress = All_Checks then
|
|
|
1114 declare
|
|
|
1115 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
|
|
|
1116 begin
|
|
|
1117 Scope_Suppress.Suppress := (others => True);
|
|
|
1118 Insert_After_And_Analyze (N, M);
|
|
|
1119 Scope_Suppress.Suppress := Svs;
|
|
|
1120 end;
|
|
|
1121
|
|
|
1122 else
|
|
|
1123 declare
|
|
|
1124 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
|
|
|
1125 begin
|
|
|
1126 Scope_Suppress.Suppress (Suppress) := True;
|
|
|
1127 Insert_After_And_Analyze (N, M);
|
|
|
1128 Scope_Suppress.Suppress (Suppress) := Svg;
|
|
|
1129 end;
|
|
|
1130 end if;
|
|
|
1131 end Insert_After_And_Analyze;
|
|
|
1132
|
|
|
1133 -------------------------------
|
|
|
1134 -- Insert_Before_And_Analyze --
|
|
|
1135 -------------------------------
|
|
|
1136
|
|
|
1137 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
|
|
|
1138 Node : Node_Id;
|
|
|
1139
|
|
|
1140 begin
|
|
|
1141 if Present (M) then
|
|
|
1142
|
|
|
1143 -- Capture the Node_Id of the first list node to be inserted.
|
|
|
1144 -- This will still be the first node after the insert operation,
|
|
|
1145 -- since Insert_List_After does not modify the Node_Id values.
|
|
|
1146
|
|
|
1147 Node := M;
|
|
|
1148 Insert_Before (N, M);
|
|
|
1149
|
|
|
1150 -- The insertion does not change the Id's of any of the nodes in
|
|
|
1151 -- the list, and they are still linked, so we can simply loop from
|
|
|
1152 -- the original first node until we meet the node before which the
|
|
|
1153 -- insertion is occurring. Note that this properly handles the case
|
|
|
1154 -- where any of the analyzed nodes insert nodes after themselves,
|
|
|
1155 -- expecting them to get analyzed.
|
|
|
1156
|
|
|
1157 while Node /= N loop
|
|
|
1158 Analyze (Node);
|
|
|
1159 Mark_Rewrite_Insertion (Node);
|
|
|
1160 Next (Node);
|
|
|
1161 end loop;
|
|
|
1162 end if;
|
|
|
1163 end Insert_Before_And_Analyze;
|
|
|
1164
|
|
|
1165 -- Version with check(s) suppressed
|
|
|
1166
|
|
|
1167 procedure Insert_Before_And_Analyze
|
|
|
1168 (N : Node_Id;
|
|
|
1169 M : Node_Id;
|
|
|
1170 Suppress : Check_Id)
|
|
|
1171 is
|
|
|
1172 begin
|
|
|
1173 if Suppress = All_Checks then
|
|
|
1174 declare
|
|
|
1175 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
|
|
|
1176 begin
|
|
|
1177 Scope_Suppress.Suppress := (others => True);
|
|
|
1178 Insert_Before_And_Analyze (N, M);
|
|
|
1179 Scope_Suppress.Suppress := Svs;
|
|
|
1180 end;
|
|
|
1181
|
|
|
1182 else
|
|
|
1183 declare
|
|
|
1184 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
|
|
|
1185 begin
|
|
|
1186 Scope_Suppress.Suppress (Suppress) := True;
|
|
|
1187 Insert_Before_And_Analyze (N, M);
|
|
|
1188 Scope_Suppress.Suppress (Suppress) := Svg;
|
|
|
1189 end;
|
|
|
1190 end if;
|
|
|
1191 end Insert_Before_And_Analyze;
|
|
|
1192
|
|
|
1193 -----------------------------------
|
|
|
1194 -- Insert_List_After_And_Analyze --
|
|
|
1195 -----------------------------------
|
|
|
1196
|
|
|
1197 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
|
|
|
1198 After : constant Node_Id := Next (N);
|
|
|
1199 Node : Node_Id;
|
|
|
1200
|
|
|
1201 begin
|
|
|
1202 if Is_Non_Empty_List (L) then
|
|
|
1203
|
|
|
1204 -- Capture the Node_Id of the first list node to be inserted.
|
|
|
1205 -- This will still be the first node after the insert operation,
|
|
|
1206 -- since Insert_List_After does not modify the Node_Id values.
|
|
|
1207
|
|
|
1208 Node := First (L);
|
|
|
1209 Insert_List_After (N, L);
|
|
|
1210
|
|
|
1211 -- Now just analyze from the original first node until we get to the
|
|
|
1212 -- successor of the original insertion point (which may be Empty if
|
|
|
1213 -- the insertion point was at the end of the list). Note that this
|
|
|
1214 -- properly handles the case where any of the analyze calls result in
|
|
|
1215 -- the insertion of nodes after the analyzed node (possibly calling
|
|
|
1216 -- this routine recursively).
|
|
|
1217
|
|
|
1218 while Node /= After loop
|
|
|
1219 Analyze (Node);
|
|
|
1220 Mark_Rewrite_Insertion (Node);
|
|
|
1221 Next (Node);
|
|
|
1222 end loop;
|
|
|
1223 end if;
|
|
|
1224 end Insert_List_After_And_Analyze;
|
|
|
1225
|
|
|
1226 ------------------------------------
|
|
|
1227 -- Insert_List_Before_And_Analyze --
|
|
|
1228 ------------------------------------
|
|
|
1229
|
|
|
1230 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
|
|
|
1231 Node : Node_Id;
|
|
|
1232
|
|
|
1233 begin
|
|
|
1234 if Is_Non_Empty_List (L) then
|
|
|
1235
|
|
|
1236 -- Capture the Node_Id of the first list node to be inserted. This
|
|
|
1237 -- will still be the first node after the insert operation, since
|
|
|
1238 -- Insert_List_After does not modify the Node_Id values.
|
|
|
1239
|
|
|
1240 Node := First (L);
|
|
|
1241 Insert_List_Before (N, L);
|
|
|
1242
|
|
|
1243 -- The insertion does not change the Id's of any of the nodes in
|
|
|
1244 -- the list, and they are still linked, so we can simply loop from
|
|
|
1245 -- the original first node until we meet the node before which the
|
|
|
1246 -- insertion is occurring. Note that this properly handles the case
|
|
|
1247 -- where any of the analyzed nodes insert nodes after themselves,
|
|
|
1248 -- expecting them to get analyzed.
|
|
|
1249
|
|
|
1250 while Node /= N loop
|
|
|
1251 Analyze (Node);
|
|
|
1252 Mark_Rewrite_Insertion (Node);
|
|
|
1253 Next (Node);
|
|
|
1254 end loop;
|
|
|
1255 end if;
|
|
|
1256 end Insert_List_Before_And_Analyze;
|
|
|
1257
|
|
|
1258 ----------
|
|
|
1259 -- Lock --
|
|
|
1260 ----------
|
|
|
1261
|
|
|
1262 procedure Lock is
|
|
|
1263 begin
|
|
|
1264 Scope_Stack.Release;
|
|
|
1265 Scope_Stack.Locked := True;
|
|
|
1266 end Lock;
|
|
|
1267
|
|
|
1268 ------------------------
|
|
|
1269 -- Preanalysis_Active --
|
|
|
1270 ------------------------
|
|
|
1271
|
|
|
1272 function Preanalysis_Active return Boolean is
|
|
|
1273 begin
|
|
|
1274 return not Full_Analysis and not Expander_Active;
|
|
|
1275 end Preanalysis_Active;
|
|
|
1276
|
|
|
1277 ----------------
|
|
|
1278 -- Preanalyze --
|
|
|
1279 ----------------
|
|
|
1280
|
|
|
1281 procedure Preanalyze (N : Node_Id) is
|
|
|
1282 Save_Full_Analysis : constant Boolean := Full_Analysis;
|
|
|
1283
|
|
|
1284 begin
|
|
|
1285 Full_Analysis := False;
|
|
|
1286 Expander_Mode_Save_And_Set (False);
|
|
|
1287
|
|
|
1288 Analyze (N);
|
|
|
1289
|
|
|
1290 Expander_Mode_Restore;
|
|
|
1291 Full_Analysis := Save_Full_Analysis;
|
|
|
1292 end Preanalyze;
|
|
|
1293
|
|
|
1294 --------------------------------------
|
|
|
1295 -- Push_Global_Suppress_Stack_Entry --
|
|
|
1296 --------------------------------------
|
|
|
1297
|
|
|
1298 procedure Push_Global_Suppress_Stack_Entry
|
|
|
1299 (Entity : Entity_Id;
|
|
|
1300 Check : Check_Id;
|
|
|
1301 Suppress : Boolean)
|
|
|
1302 is
|
|
|
1303 begin
|
|
|
1304 Global_Suppress_Stack_Top :=
|
|
|
1305 new Suppress_Stack_Entry'
|
|
|
1306 (Entity => Entity,
|
|
|
1307 Check => Check,
|
|
|
1308 Suppress => Suppress,
|
|
|
1309 Prev => Global_Suppress_Stack_Top,
|
|
|
1310 Next => Suppress_Stack_Entries);
|
|
|
1311 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
|
|
|
1312 return;
|
|
|
1313 end Push_Global_Suppress_Stack_Entry;
|
|
|
1314
|
|
|
1315 -------------------------------------
|
|
|
1316 -- Push_Local_Suppress_Stack_Entry --
|
|
|
1317 -------------------------------------
|
|
|
1318
|
|
|
1319 procedure Push_Local_Suppress_Stack_Entry
|
|
|
1320 (Entity : Entity_Id;
|
|
|
1321 Check : Check_Id;
|
|
|
1322 Suppress : Boolean)
|
|
|
1323 is
|
|
|
1324 begin
|
|
|
1325 Local_Suppress_Stack_Top :=
|
|
|
1326 new Suppress_Stack_Entry'
|
|
|
1327 (Entity => Entity,
|
|
|
1328 Check => Check,
|
|
|
1329 Suppress => Suppress,
|
|
|
1330 Prev => Local_Suppress_Stack_Top,
|
|
|
1331 Next => Suppress_Stack_Entries);
|
|
|
1332 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
|
|
|
1333
|
|
|
1334 return;
|
|
|
1335 end Push_Local_Suppress_Stack_Entry;
|
|
|
1336
|
|
|
1337 ---------------
|
|
|
1338 -- Semantics --
|
|
|
1339 ---------------
|
|
|
1340
|
|
|
1341 procedure Semantics (Comp_Unit : Node_Id) is
|
|
|
1342 procedure Do_Analyze;
|
|
|
1343 -- Perform the analysis of the compilation unit
|
|
|
1344
|
|
|
1345 ----------------
|
|
|
1346 -- Do_Analyze --
|
|
|
1347 ----------------
|
|
|
1348
|
|
|
1349 -- WARNING: This routine manages Ghost regions. Return statements must
|
|
|
1350 -- be replaced by gotos which jump to the end of the routine and restore
|
|
|
1351 -- the Ghost mode.
|
|
|
1352
|
|
|
1353 procedure Do_Analyze is
|
|
131
|
1354 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
|
1355 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
|
1356 -- Save the Ghost-related attributes to restore on exit
|
|
111
|
1357
|
|
|
1358 -- Generally style checks are preserved across compilations, with
|
|
|
1359 -- one exception: s-oscons.ads, which allows arbitrary long lines
|
|
|
1360 -- unconditionally, and has no restore mechanism, because it is
|
|
|
1361 -- intended as a lowest-level Pure package.
|
|
|
1362
|
|
145
|
1363 Saved_ML : constant Int := Style_Max_Line_Length;
|
|
|
1364 Saved_CML : constant Boolean := Style_Check_Max_Line_Length;
|
|
111
|
1365
|
|
|
1366 List : Elist_Id;
|
|
|
1367
|
|
|
1368 begin
|
|
|
1369 List := Save_Scope_Stack;
|
|
|
1370 Push_Scope (Standard_Standard);
|
|
|
1371
|
|
|
1372 -- Set up a clean environment before analyzing
|
|
|
1373
|
|
131
|
1374 Install_Ghost_Region (None, Empty);
|
|
|
1375
|
|
111
|
1376 Outer_Generic_Scope := Empty;
|
|
|
1377 Scope_Suppress := Suppress_Options;
|
|
|
1378 Scope_Stack.Table
|
|
|
1379 (Scope_Stack.Last).Component_Alignment_Default :=
|
|
|
1380 Configuration_Component_Alignment;
|
|
|
1381 Scope_Stack.Table
|
|
|
1382 (Scope_Stack.Last).Is_Active_Stack_Base := True;
|
|
|
1383
|
|
|
1384 -- Now analyze the top level compilation unit node
|
|
|
1385
|
|
|
1386 Analyze (Comp_Unit);
|
|
|
1387
|
|
|
1388 -- Check for scope mismatch on exit from compilation
|
|
|
1389
|
|
|
1390 pragma Assert (Current_Scope = Standard_Standard
|
|
|
1391 or else Comp_Unit = Cunit (Main_Unit));
|
|
|
1392
|
|
|
1393 -- Then pop entry for Standard, and pop implicit types
|
|
|
1394
|
|
|
1395 Pop_Scope;
|
|
131
|
1396 Restore_Scope_Stack (List);
|
|
|
1397 Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
|
1398 Style_Max_Line_Length := Saved_ML;
|
|
145
|
1399 Style_Check_Max_Line_Length := Saved_CML;
|
|
111
|
1400 end Do_Analyze;
|
|
|
1401
|
|
|
1402 -- Local variables
|
|
|
1403
|
|
|
1404 -- The following locations save the corresponding global flags and
|
|
|
1405 -- variables so that they can be restored on completion. This is needed
|
|
|
1406 -- so that calls to Rtsfind start with the proper default values for
|
|
|
1407 -- these variables, and also that such calls do not disturb the settings
|
|
|
1408 -- for units being analyzed at a higher level.
|
|
|
1409
|
|
|
1410 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
|
|
|
1411 S_Full_Analysis : constant Boolean := Full_Analysis;
|
|
|
1412 S_GNAT_Mode : constant Boolean := GNAT_Mode;
|
|
|
1413 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
|
|
|
1414 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
|
|
|
1415 S_In_Default_Expr : constant Boolean := In_Default_Expr;
|
|
|
1416 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
|
|
|
1417 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
|
|
|
1418 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
|
|
|
1419 S_Style_Check : constant Boolean := Style_Check;
|
|
|
1420
|
|
|
1421 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
|
|
|
1422
|
|
|
1423 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit);
|
|
|
1424 -- New value of Current_Sem_Unit
|
|
|
1425
|
|
|
1426 Generic_Main : constant Boolean :=
|
|
|
1427 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration;
|
|
|
1428 -- If the main unit is generic, every compiled unit, including its
|
|
|
1429 -- context, is compiled with expansion disabled.
|
|
|
1430
|
|
|
1431 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean :=
|
|
|
1432 Curunit = Main_Unit
|
|
|
1433 or else
|
|
|
1434 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
|
|
|
1435 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit));
|
|
|
1436 -- Configuration flags have special settings when compiling a predefined
|
|
|
1437 -- file as a main unit. This applies to its spec as well.
|
|
|
1438
|
|
|
1439 Ext_Main_Source_Unit : constant Boolean :=
|
|
|
1440 In_Extended_Main_Source_Unit (Comp_Unit);
|
|
|
1441 -- Determine if unit is in extended main source unit
|
|
|
1442
|
|
131
|
1443 Save_Config_Attrs : Config_Switches_Type;
|
|
111
|
1444 -- Variable used to save values of config switches while we analyze the
|
|
|
1445 -- new unit, to be restored on exit for proper recursive behavior.
|
|
|
1446
|
|
|
1447 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
|
|
|
1448 -- Used to save non-partition wide restrictions before processing new
|
|
|
1449 -- unit. All with'ed units are analyzed with config restrictions reset
|
|
|
1450 -- and we need to restore these saved values at the end.
|
|
|
1451
|
|
131
|
1452 Save_Preanalysis_Counter : constant Nat :=
|
|
|
1453 Inside_Preanalysis_Without_Freezing;
|
|
|
1454 -- Saves the preanalysis nesting-level counter; required since we may
|
|
|
1455 -- need to analyze a unit as a consequence of the preanalysis of an
|
|
|
1456 -- expression without freezing (and the loaded unit must be fully
|
|
|
1457 -- analyzed).
|
|
|
1458
|
|
111
|
1459 -- Start of processing for Semantics
|
|
|
1460
|
|
|
1461 begin
|
|
131
|
1462 Inside_Preanalysis_Without_Freezing := 0;
|
|
|
1463
|
|
111
|
1464 if Debug_Unit_Walk then
|
|
|
1465 if Already_Analyzed then
|
|
|
1466 Write_Str ("(done)");
|
|
|
1467 end if;
|
|
|
1468
|
|
|
1469 Write_Unit_Info
|
|
|
1470 (Get_Cunit_Unit_Number (Comp_Unit),
|
|
|
1471 Unit (Comp_Unit),
|
|
|
1472 Prefix => "--> ");
|
|
|
1473 Indent;
|
|
|
1474 end if;
|
|
|
1475
|
|
|
1476 Compiler_State := Analyzing;
|
|
|
1477 Current_Sem_Unit := Curunit;
|
|
|
1478
|
|
|
1479 -- Compile predefined units with GNAT_Mode set to True, to properly
|
|
|
1480 -- process the categorization stuff. However, do not set GNAT_Mode
|
|
|
1481 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
|
|
|
1482 -- Sequential_IO) as this would prevent pragma Extend_System from being
|
|
|
1483 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
|
|
|
1484
|
|
|
1485 if Is_Predefined_Unit (Current_Sem_Unit)
|
|
|
1486 and then not Is_Predefined_Renaming (Current_Sem_Unit)
|
|
|
1487 then
|
|
|
1488 GNAT_Mode := True;
|
|
|
1489 end if;
|
|
|
1490
|
|
|
1491 -- For generic main, never do expansion
|
|
|
1492
|
|
|
1493 if Generic_Main then
|
|
|
1494 Expander_Mode_Save_And_Set (False);
|
|
|
1495
|
|
|
1496 -- Non generic case
|
|
|
1497
|
|
|
1498 else
|
|
|
1499 Expander_Mode_Save_And_Set
|
|
|
1500
|
|
|
1501 -- Turn on expansion if generating code
|
|
|
1502
|
|
|
1503 (Operating_Mode = Generate_Code
|
|
|
1504
|
|
|
1505 -- Or if special debug flag -gnatdx is set
|
|
|
1506
|
|
|
1507 or else Debug_Flag_X
|
|
|
1508
|
|
|
1509 -- Or if in configuration run-time mode. We do this so we get
|
|
|
1510 -- error messages about missing entities in the run-time even
|
|
|
1511 -- if we are compiling in -gnatc (no code generation) mode.
|
|
|
1512 -- Similar processing applies to No_Run_Time_Mode. However,
|
|
|
1513 -- don't do this if debug flag -gnatd.Z is set or when we are
|
|
|
1514 -- compiling a separate unit (this is to handle a situation
|
|
|
1515 -- where this new processing causes trouble).
|
|
|
1516
|
|
|
1517 or else
|
|
|
1518 ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
|
|
|
1519 and then not Debug_Flag_Dot_ZZ
|
|
|
1520 and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
|
|
|
1521 end if;
|
|
|
1522
|
|
|
1523 Full_Analysis := True;
|
|
|
1524 Inside_A_Generic := False;
|
|
|
1525 In_Assertion_Expr := 0;
|
|
|
1526 In_Default_Expr := False;
|
|
|
1527 In_Spec_Expression := False;
|
|
|
1528 Set_Comes_From_Source_Default (False);
|
|
|
1529
|
|
|
1530 -- Save current config switches and reset then appropriately
|
|
|
1531
|
|
131
|
1532 Save_Config_Attrs := Save_Config_Switches;
|
|
|
1533 Set_Config_Switches
|
|
111
|
1534 (Is_Internal_Unit (Current_Sem_Unit),
|
|
|
1535 Is_Main_Unit_Or_Main_Unit_Spec);
|
|
|
1536
|
|
|
1537 -- Save current non-partition-wide restrictions
|
|
|
1538
|
|
|
1539 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
|
|
|
1540
|
|
|
1541 -- For unit in main extended unit, we reset the configuration values
|
|
|
1542 -- for the non-partition-wide restrictions. For other units reset them.
|
|
|
1543
|
|
|
1544 if Ext_Main_Source_Unit then
|
|
|
1545 Restore_Config_Cunit_Boolean_Restrictions;
|
|
|
1546 else
|
|
|
1547 Reset_Cunit_Boolean_Restrictions;
|
|
|
1548 end if;
|
|
|
1549
|
|
|
1550 -- Turn off style checks for unit that is not in the extended main
|
|
|
1551 -- source unit. This improves processing efficiency for such units
|
|
|
1552 -- (for which we don't want style checks anyway, and where they will
|
|
|
1553 -- get suppressed), and is definitely needed to stop some style checks
|
|
|
1554 -- from invading the run-time units (e.g. overriding checks).
|
|
|
1555
|
|
|
1556 if not Ext_Main_Source_Unit then
|
|
|
1557 Style_Check := False;
|
|
|
1558
|
|
|
1559 -- If this is part of the extended main source unit, set style check
|
|
|
1560 -- mode to match the style check mode of the main source unit itself.
|
|
|
1561
|
|
|
1562 else
|
|
|
1563 Style_Check := Style_Check_Main;
|
|
|
1564 end if;
|
|
|
1565
|
|
|
1566 -- Only do analysis of unit that has not already been analyzed
|
|
|
1567
|
|
|
1568 if not Analyzed (Comp_Unit) then
|
|
|
1569 Initialize_Version (Current_Sem_Unit);
|
|
|
1570
|
|
|
1571 -- Do analysis, and then append the compilation unit onto the
|
|
|
1572 -- Comp_Unit_List, if appropriate. This is done after analysis,
|
|
|
1573 -- so if this unit depends on some others, they have already been
|
|
|
1574 -- appended. We ignore bodies, except for the main unit itself, and
|
|
|
1575 -- for subprogram bodies that act as specs. We have also to guard
|
|
|
1576 -- against ill-formed subunits that have an improper context.
|
|
|
1577
|
|
|
1578 Do_Analyze;
|
|
|
1579
|
|
|
1580 if Present (Comp_Unit)
|
|
|
1581 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
|
|
|
1582 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
|
|
|
1583 or else not Acts_As_Spec (Comp_Unit))
|
|
145
|
1584 and then not Ext_Main_Source_Unit
|
|
111
|
1585 then
|
|
|
1586 null;
|
|
|
1587
|
|
|
1588 else
|
|
|
1589 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
|
|
|
1590
|
|
|
1591 if Debug_Unit_Walk then
|
|
|
1592 Write_Str ("Appending ");
|
|
|
1593 Write_Unit_Info
|
|
|
1594 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
|
|
|
1595 end if;
|
|
|
1596 end if;
|
|
|
1597 end if;
|
|
|
1598
|
|
|
1599 -- Save indication of dynamic elaboration checks for ALI file
|
|
|
1600
|
|
|
1601 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
|
|
|
1602
|
|
|
1603 -- Restore settings of saved switches to entry values
|
|
|
1604
|
|
|
1605 Current_Sem_Unit := S_Current_Sem_Unit;
|
|
|
1606 Full_Analysis := S_Full_Analysis;
|
|
|
1607 Global_Discard_Names := S_Global_Dis_Names;
|
|
|
1608 GNAT_Mode := S_GNAT_Mode;
|
|
|
1609 In_Assertion_Expr := S_In_Assertion_Expr;
|
|
|
1610 In_Default_Expr := S_In_Default_Expr;
|
|
|
1611 In_Spec_Expression := S_In_Spec_Expr;
|
|
|
1612 Inside_A_Generic := S_Inside_A_Generic;
|
|
|
1613 Outer_Generic_Scope := S_Outer_Gen_Scope;
|
|
|
1614 Style_Check := S_Style_Check;
|
|
|
1615
|
|
131
|
1616 Restore_Config_Switches (Save_Config_Attrs);
|
|
111
|
1617
|
|
|
1618 -- Deal with restore of restrictions
|
|
|
1619
|
|
|
1620 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
|
|
|
1621
|
|
|
1622 Expander_Mode_Restore;
|
|
|
1623
|
|
|
1624 if Debug_Unit_Walk then
|
|
|
1625 Outdent;
|
|
|
1626
|
|
|
1627 if Already_Analyzed then
|
|
|
1628 Write_Str ("(done)");
|
|
|
1629 end if;
|
|
|
1630
|
|
|
1631 Write_Unit_Info
|
|
|
1632 (Get_Cunit_Unit_Number (Comp_Unit),
|
|
|
1633 Unit (Comp_Unit),
|
|
|
1634 Prefix => "<-- ");
|
|
|
1635 end if;
|
|
131
|
1636
|
|
|
1637 Inside_Preanalysis_Without_Freezing := Save_Preanalysis_Counter;
|
|
111
|
1638 end Semantics;
|
|
|
1639
|
|
|
1640 --------
|
|
|
1641 -- ss --
|
|
|
1642 --------
|
|
|
1643
|
|
|
1644 function ss (Index : Int) return Scope_Stack_Entry is
|
|
|
1645 begin
|
|
|
1646 return Scope_Stack.Table (Index);
|
|
|
1647 end ss;
|
|
|
1648
|
|
|
1649 ---------
|
|
|
1650 -- sst --
|
|
|
1651 ---------
|
|
|
1652
|
|
|
1653 function sst return Scope_Stack_Entry is
|
|
|
1654 begin
|
|
|
1655 return ss (Scope_Stack.Last);
|
|
|
1656 end sst;
|
|
|
1657
|
|
|
1658 ------------
|
|
|
1659 -- Unlock --
|
|
|
1660 ------------
|
|
|
1661
|
|
|
1662 procedure Unlock is
|
|
|
1663 begin
|
|
|
1664 Scope_Stack.Locked := False;
|
|
|
1665 end Unlock;
|
|
|
1666
|
|
|
1667 ------------------------
|
|
|
1668 -- Walk_Library_Items --
|
|
|
1669 ------------------------
|
|
|
1670
|
|
|
1671 procedure Walk_Library_Items is
|
|
|
1672 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
|
|
|
1673 pragma Pack (Unit_Number_Set);
|
|
|
1674
|
|
|
1675 Main_CU : constant Node_Id := Cunit (Main_Unit);
|
|
|
1676
|
|
|
1677 Seen, Done : Unit_Number_Set := (others => False);
|
|
|
1678 -- Seen (X) is True after we have seen unit X in the walk. This is used
|
|
|
1679 -- to prevent processing the same unit more than once. Done (X) is True
|
|
|
1680 -- after we have fully processed X, and is used only for debugging
|
|
|
1681 -- printouts and assertions.
|
|
|
1682
|
|
|
1683 Do_Main : Boolean := False;
|
|
|
1684 -- Flag to delay processing the main body until after all other units.
|
|
|
1685 -- This is needed because the spec of the main unit may appear in the
|
|
|
1686 -- context of some other unit. We do not want this to force processing
|
|
|
1687 -- of the main body before all other units have been processed.
|
|
|
1688 --
|
|
|
1689 -- Another circularity pattern occurs when the main unit is a child unit
|
|
|
1690 -- and the body of an ancestor has a with-clause of the main unit or on
|
|
|
1691 -- one of its children. In both cases the body in question has a with-
|
|
|
1692 -- clause on the main unit, and must be excluded from the traversal. In
|
|
|
1693 -- some convoluted cases this may lead to a CodePeer error because the
|
|
|
1694 -- spec of a subprogram declared in an instance within the parent will
|
|
|
1695 -- not be seen in the main unit.
|
|
|
1696
|
|
|
1697 function Depends_On_Main (CU : Node_Id) return Boolean;
|
|
|
1698 -- The body of a unit that is withed by the spec of the main unit may in
|
|
|
1699 -- turn have a with_clause on that spec. In that case do not traverse
|
|
|
1700 -- the body, to prevent loops. It can also happen that the main body has
|
|
|
1701 -- a with_clause on a child, which of course has an implicit with on its
|
|
|
1702 -- parent. It's OK to traverse the child body if the main spec has been
|
|
|
1703 -- processed, otherwise we also have a circularity to avoid.
|
|
|
1704
|
|
|
1705 procedure Do_Action (CU : Node_Id; Item : Node_Id);
|
|
|
1706 -- Calls Action, with some validity checks
|
|
|
1707
|
|
|
1708 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
|
|
|
1709 -- Calls Do_Action, first on the units with'ed by this one, then on
|
|
|
1710 -- this unit. If it's an instance body, do the spec first. If it is
|
|
|
1711 -- an instance spec, do the body last.
|
|
|
1712
|
|
|
1713 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
|
|
|
1714 -- Apply Do_Unit_And_Dependents to a unit in a context clause
|
|
|
1715
|
|
|
1716 procedure Process_Bodies_In_Context (Comp : Node_Id);
|
|
|
1717 -- The main unit and its spec may depend on bodies that contain generics
|
|
|
1718 -- that are instantiated in them. Iterate through the corresponding
|
|
|
1719 -- contexts before processing main (spec/body) itself, to process bodies
|
|
131
|
1720 -- that may be present, together with their context. The spec of main
|
|
111
|
1721 -- is processed wherever it appears in the list of units, while the body
|
|
|
1722 -- is processed as the last unit in the list.
|
|
|
1723
|
|
|
1724 ---------------------
|
|
|
1725 -- Depends_On_Main --
|
|
|
1726 ---------------------
|
|
|
1727
|
|
|
1728 function Depends_On_Main (CU : Node_Id) return Boolean is
|
|
|
1729 CL : Node_Id;
|
|
|
1730 MCU : constant Node_Id := Unit (Main_CU);
|
|
|
1731
|
|
|
1732 begin
|
|
|
1733 -- Problem does not arise with main subprograms
|
|
|
1734
|
|
145
|
1735 if not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) then
|
|
111
|
1736 return False;
|
|
|
1737 end if;
|
|
|
1738
|
|
145
|
1739 CL := First (Context_Items (CU));
|
|
|
1740
|
|
111
|
1741 while Present (CL) loop
|
|
|
1742 if Nkind (CL) = N_With_Clause
|
|
|
1743 and then Library_Unit (CL) = Main_CU
|
|
|
1744 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
|
|
|
1745 then
|
|
|
1746 return True;
|
|
|
1747 end if;
|
|
|
1748
|
|
|
1749 Next (CL);
|
|
|
1750 end loop;
|
|
|
1751
|
|
|
1752 return False;
|
|
|
1753 end Depends_On_Main;
|
|
|
1754
|
|
|
1755 ---------------
|
|
|
1756 -- Do_Action --
|
|
|
1757 ---------------
|
|
|
1758
|
|
|
1759 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
|
|
|
1760 begin
|
|
|
1761 -- This calls Action at the end. All the preceding code is just
|
|
|
1762 -- assertions and debugging output.
|
|
|
1763
|
|
|
1764 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
|
|
|
1765
|
|
|
1766 case Nkind (Item) is
|
|
|
1767 when N_Generic_Function_Renaming_Declaration
|
|
|
1768 | N_Generic_Package_Declaration
|
|
|
1769 | N_Generic_Package_Renaming_Declaration
|
|
|
1770 | N_Generic_Procedure_Renaming_Declaration
|
|
|
1771 | N_Generic_Subprogram_Declaration
|
|
|
1772 | N_Package_Declaration
|
|
|
1773 | N_Package_Renaming_Declaration
|
|
|
1774 | N_Subprogram_Declaration
|
|
|
1775 | N_Subprogram_Renaming_Declaration
|
|
|
1776 =>
|
|
|
1777 -- Specs are OK
|
|
|
1778
|
|
|
1779 null;
|
|
|
1780
|
|
|
1781 when N_Package_Body =>
|
|
|
1782
|
|
|
1783 -- Package bodies are processed separately if the main unit
|
|
|
1784 -- depends on them.
|
|
|
1785
|
|
|
1786 null;
|
|
|
1787
|
|
|
1788 when N_Subprogram_Body =>
|
|
|
1789
|
|
|
1790 -- A subprogram body must be the main unit
|
|
|
1791
|
|
131
|
1792 pragma Assert (Acts_As_Spec (CU) or else CU = Main_CU);
|
|
111
|
1793 null;
|
|
|
1794
|
|
|
1795 when N_Function_Instantiation
|
|
|
1796 | N_Package_Instantiation
|
|
|
1797 | N_Procedure_Instantiation
|
|
|
1798 =>
|
|
|
1799 -- Can only happen if some generic body (needed for gnat2scil
|
|
|
1800 -- traversal, but not by GNAT) is not available, ignore.
|
|
|
1801
|
|
|
1802 null;
|
|
|
1803
|
|
|
1804 -- All other cases cannot happen
|
|
|
1805
|
|
|
1806 when N_Subunit =>
|
|
|
1807 pragma Assert (False, "subunit");
|
|
|
1808 null;
|
|
|
1809
|
|
|
1810 when N_Null_Statement =>
|
|
|
1811
|
|
|
1812 -- Do not call Action for an ignored ghost unit
|
|
|
1813
|
|
|
1814 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item)));
|
|
|
1815 return;
|
|
|
1816
|
|
|
1817 when others =>
|
|
|
1818 pragma Assert (False);
|
|
|
1819 null;
|
|
|
1820 end case;
|
|
|
1821
|
|
|
1822 if Present (CU) then
|
|
|
1823 pragma Assert (Item /= Stand.Standard_Package_Node);
|
|
|
1824 pragma Assert (Item = Unit (CU));
|
|
|
1825
|
|
|
1826 declare
|
|
|
1827 Unit_Num : constant Unit_Number_Type :=
|
|
|
1828 Get_Cunit_Unit_Number (CU);
|
|
|
1829
|
|
|
1830 procedure Assert_Done (Withed_Unit : Node_Id);
|
|
|
1831 -- Assert Withed_Unit is already Done, unless it's a body. It
|
|
|
1832 -- might seem strange for a with_clause to refer to a body, but
|
|
|
1833 -- this happens in the case of a generic instantiation, which
|
|
|
1834 -- gets transformed into the instance body (and the instance
|
|
|
1835 -- spec is also created). With clauses pointing to the
|
|
|
1836 -- instantiation end up pointing to the instance body.
|
|
|
1837
|
|
|
1838 -----------------
|
|
|
1839 -- Assert_Done --
|
|
|
1840 -----------------
|
|
|
1841
|
|
|
1842 procedure Assert_Done (Withed_Unit : Node_Id) is
|
|
|
1843 begin
|
|
|
1844 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
|
|
|
1845 if not Nkind_In
|
|
|
1846 (Unit (Withed_Unit),
|
|
|
1847 N_Generic_Package_Declaration,
|
|
|
1848 N_Package_Body,
|
|
|
1849 N_Package_Renaming_Declaration,
|
|
|
1850 N_Subprogram_Body)
|
|
|
1851 then
|
|
|
1852 Write_Unit_Name
|
|
|
1853 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
|
|
|
1854 Write_Str (" not yet walked!");
|
|
|
1855
|
|
|
1856 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
|
|
|
1857 Write_Str (" (self-ref)");
|
|
|
1858 end if;
|
|
|
1859
|
|
|
1860 Write_Eol;
|
|
|
1861
|
|
|
1862 pragma Assert (False);
|
|
|
1863 end if;
|
|
|
1864 end if;
|
|
|
1865 end Assert_Done;
|
|
|
1866
|
|
|
1867 procedure Assert_Withed_Units_Done is
|
|
|
1868 new Walk_Withs (Assert_Done);
|
|
|
1869
|
|
|
1870 begin
|
|
|
1871 if Debug_Unit_Walk then
|
|
|
1872 Write_Unit_Info (Unit_Num, Item, Withs => True);
|
|
|
1873 end if;
|
|
|
1874
|
|
|
1875 -- Main unit should come last, except in the case where we
|
|
|
1876 -- skipped System_Aux_Id, in which case we missed the things it
|
|
|
1877 -- depends on, and in the case of parent bodies if present.
|
|
|
1878
|
|
|
1879 pragma Assert
|
|
|
1880 (not Done (Main_Unit)
|
|
|
1881 or else Present (System_Aux_Id)
|
|
|
1882 or else Nkind (Item) = N_Package_Body);
|
|
|
1883
|
|
|
1884 -- We shouldn't do the same thing twice
|
|
|
1885
|
|
|
1886 pragma Assert (not Done (Unit_Num));
|
|
|
1887
|
|
|
1888 -- Everything we depend upon should already be done
|
|
|
1889
|
|
|
1890 pragma Debug
|
|
|
1891 (Assert_Withed_Units_Done (CU, Include_Limited => False));
|
|
|
1892 end;
|
|
|
1893
|
|
|
1894 else
|
|
|
1895 -- Must be Standard, which has no entry in the units table
|
|
|
1896
|
|
|
1897 pragma Assert (Item = Stand.Standard_Package_Node);
|
|
|
1898
|
|
|
1899 if Debug_Unit_Walk then
|
|
|
1900 Write_Line ("Standard");
|
|
|
1901 end if;
|
|
|
1902 end if;
|
|
|
1903
|
|
|
1904 Action (Item);
|
|
|
1905 end Do_Action;
|
|
|
1906
|
|
|
1907 --------------------
|
|
|
1908 -- Do_Withed_Unit --
|
|
|
1909 --------------------
|
|
|
1910
|
|
|
1911 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
|
|
|
1912 begin
|
|
|
1913 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
|
|
|
1914
|
|
|
1915 -- If the unit in the with_clause is a generic instance, the clause
|
|
|
1916 -- now denotes the instance body. Traverse the corresponding spec
|
|
|
1917 -- because there may be no other dependence that will force the
|
|
|
1918 -- traversal of its own context.
|
|
|
1919
|
|
|
1920 if Nkind (Unit (Withed_Unit)) = N_Package_Body
|
|
|
1921 and then Is_Generic_Instance
|
|
|
1922 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
|
|
|
1923 then
|
|
|
1924 Do_Withed_Unit (Library_Unit (Withed_Unit));
|
|
|
1925 end if;
|
|
|
1926 end Do_Withed_Unit;
|
|
|
1927
|
|
|
1928 ----------------------------
|
|
|
1929 -- Do_Unit_And_Dependents --
|
|
|
1930 ----------------------------
|
|
|
1931
|
|
|
1932 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
|
|
|
1933 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
|
|
|
1934 Child : Node_Id;
|
|
|
1935 Body_U : Unit_Number_Type;
|
|
|
1936 Parent_CU : Node_Id;
|
|
|
1937
|
|
|
1938 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
|
|
|
1939
|
|
|
1940 begin
|
|
|
1941 if not Seen (Unit_Num) then
|
|
|
1942
|
|
|
1943 -- Process the with clauses
|
|
|
1944
|
|
|
1945 Do_Withed_Units (CU, Include_Limited => False);
|
|
|
1946
|
|
|
1947 -- Process the unit if it is a spec or the main unit, if it
|
|
|
1948 -- has no previous spec or we have done all other units.
|
|
|
1949
|
|
|
1950 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
|
|
|
1951 or else Acts_As_Spec (CU)
|
|
|
1952 then
|
|
131
|
1953 if CU = Main_CU and then not Do_Main then
|
|
111
|
1954 Seen (Unit_Num) := False;
|
|
|
1955
|
|
|
1956 else
|
|
|
1957 Seen (Unit_Num) := True;
|
|
|
1958
|
|
|
1959 if CU = Library_Unit (Main_CU) then
|
|
|
1960 Process_Bodies_In_Context (CU);
|
|
|
1961
|
|
|
1962 -- If main is a child unit, examine parent unit contexts
|
|
|
1963 -- to see if they include instantiated units. Also, if
|
|
|
1964 -- the parent itself is an instance, process its body
|
|
|
1965 -- because it may contain subprograms that are called
|
|
|
1966 -- in the main unit.
|
|
|
1967
|
|
|
1968 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
|
|
|
1969 Child := Cunit_Entity (Main_Unit);
|
|
|
1970 while Is_Child_Unit (Child) loop
|
|
|
1971 Parent_CU :=
|
|
|
1972 Cunit
|
|
|
1973 (Get_Cunit_Entity_Unit_Number (Scope (Child)));
|
|
|
1974 Process_Bodies_In_Context (Parent_CU);
|
|
|
1975
|
|
|
1976 if Nkind (Unit (Parent_CU)) = N_Package_Body
|
|
|
1977 and then
|
|
|
1978 Nkind (Original_Node (Unit (Parent_CU)))
|
|
|
1979 = N_Package_Instantiation
|
|
|
1980 and then
|
|
|
1981 not Seen (Get_Cunit_Unit_Number (Parent_CU))
|
|
|
1982 then
|
|
|
1983 Body_U := Get_Cunit_Unit_Number (Parent_CU);
|
|
|
1984 Seen (Body_U) := True;
|
|
|
1985 Do_Action (Parent_CU, Unit (Parent_CU));
|
|
|
1986 Done (Body_U) := True;
|
|
|
1987 end if;
|
|
|
1988
|
|
|
1989 Child := Scope (Child);
|
|
|
1990 end loop;
|
|
|
1991 end if;
|
|
|
1992 end if;
|
|
|
1993
|
|
|
1994 Do_Action (CU, Item);
|
|
|
1995 Done (Unit_Num) := True;
|
|
|
1996 end if;
|
|
|
1997 end if;
|
|
|
1998 end if;
|
|
|
1999 end Do_Unit_And_Dependents;
|
|
|
2000
|
|
|
2001 -------------------------------
|
|
|
2002 -- Process_Bodies_In_Context --
|
|
|
2003 -------------------------------
|
|
|
2004
|
|
|
2005 procedure Process_Bodies_In_Context (Comp : Node_Id) is
|
|
|
2006 Body_CU : Node_Id;
|
|
|
2007 Body_U : Unit_Number_Type;
|
|
|
2008 Clause : Node_Id;
|
|
|
2009 Spec : Node_Id;
|
|
|
2010
|
|
|
2011 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
|
|
|
2012
|
|
|
2013 -- Start of processing for Process_Bodies_In_Context
|
|
|
2014
|
|
|
2015 begin
|
|
|
2016 Clause := First (Context_Items (Comp));
|
|
|
2017 while Present (Clause) loop
|
|
|
2018 if Nkind (Clause) = N_With_Clause then
|
|
|
2019 Spec := Library_Unit (Clause);
|
|
|
2020 Body_CU := Library_Unit (Spec);
|
|
|
2021
|
|
|
2022 -- If we are processing the spec of the main unit, load bodies
|
|
|
2023 -- only if the with_clause indicates that it forced the loading
|
|
|
2024 -- of the body for a generic instantiation. Note that bodies of
|
|
|
2025 -- parents that are instances have been loaded already.
|
|
|
2026
|
|
|
2027 if Present (Body_CU)
|
|
131
|
2028 and then Body_CU /= Main_CU
|
|
111
|
2029 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
|
|
131
|
2030 and then Nkind (Unit (Comp)) /= N_Package_Declaration
|
|
111
|
2031 then
|
|
|
2032 Body_U := Get_Cunit_Unit_Number (Body_CU);
|
|
|
2033
|
|
|
2034 if not Seen (Body_U)
|
|
|
2035 and then not Depends_On_Main (Body_CU)
|
|
|
2036 then
|
|
|
2037 Seen (Body_U) := True;
|
|
|
2038 Do_Withed_Units (Body_CU, Include_Limited => False);
|
|
|
2039 Do_Action (Body_CU, Unit (Body_CU));
|
|
|
2040 Done (Body_U) := True;
|
|
|
2041 end if;
|
|
|
2042 end if;
|
|
|
2043 end if;
|
|
|
2044
|
|
|
2045 Next (Clause);
|
|
|
2046 end loop;
|
|
|
2047 end Process_Bodies_In_Context;
|
|
|
2048
|
|
|
2049 -- Local Declarations
|
|
|
2050
|
|
|
2051 Cur : Elmt_Id;
|
|
|
2052
|
|
|
2053 -- Start of processing for Walk_Library_Items
|
|
|
2054
|
|
|
2055 begin
|
|
|
2056 if Debug_Unit_Walk then
|
|
|
2057 Write_Line ("Walk_Library_Items:");
|
|
|
2058 Indent;
|
|
|
2059 end if;
|
|
|
2060
|
|
|
2061 -- Do Standard first, then walk the Comp_Unit_List
|
|
|
2062
|
|
|
2063 Do_Action (Empty, Standard_Package_Node);
|
|
|
2064
|
|
|
2065 -- First place the context of all instance bodies on the corresponding
|
|
|
2066 -- spec, because it may be needed to analyze the code at the place of
|
|
|
2067 -- the instantiation.
|
|
|
2068
|
|
|
2069 Cur := First_Elmt (Comp_Unit_List);
|
|
|
2070 while Present (Cur) loop
|
|
|
2071 declare
|
|
|
2072 CU : constant Node_Id := Node (Cur);
|
|
|
2073 N : constant Node_Id := Unit (CU);
|
|
|
2074
|
|
|
2075 begin
|
|
|
2076 if Nkind (N) = N_Package_Body
|
|
|
2077 and then Is_Generic_Instance (Defining_Entity (N))
|
|
|
2078 then
|
|
|
2079 Append_List
|
|
|
2080 (Context_Items (CU), Context_Items (Library_Unit (CU)));
|
|
|
2081 end if;
|
|
|
2082
|
|
|
2083 Next_Elmt (Cur);
|
|
|
2084 end;
|
|
|
2085 end loop;
|
|
|
2086
|
|
|
2087 -- Now traverse compilation units (specs) in order
|
|
|
2088
|
|
|
2089 Cur := First_Elmt (Comp_Unit_List);
|
|
|
2090 while Present (Cur) loop
|
|
|
2091 declare
|
|
|
2092 CU : constant Node_Id := Node (Cur);
|
|
|
2093 N : constant Node_Id := Unit (CU);
|
|
|
2094 Par : Entity_Id;
|
|
|
2095
|
|
|
2096 begin
|
|
|
2097 pragma Assert (Nkind (CU) = N_Compilation_Unit);
|
|
|
2098
|
|
|
2099 case Nkind (N) is
|
|
|
2100
|
|
|
2101 -- If it is a subprogram body, process it if it has no
|
|
|
2102 -- separate spec.
|
|
|
2103
|
|
|
2104 -- If it's a package body, ignore it, unless it is a body
|
|
|
2105 -- created for an instance that is the main unit. In the case
|
|
|
2106 -- of subprograms, the body is the wrapper package. In case of
|
|
|
2107 -- a package, the original file carries the body, and the spec
|
|
|
2108 -- appears as a later entry in the units list.
|
|
|
2109
|
|
|
2110 -- Otherwise bodies appear in the list only because of inlining
|
|
|
2111 -- or instantiations, and they are processed only if relevant.
|
|
|
2112 -- The flag Withed_Body on a context clause indicates that a
|
|
|
2113 -- unit contains an instantiation that may be needed later,
|
|
|
2114 -- and therefore the body that contains the generic body (and
|
|
|
2115 -- its context) must be traversed immediately after the
|
|
|
2116 -- corresponding spec (see Do_Unit_And_Dependents).
|
|
|
2117
|
|
|
2118 -- The main unit itself is processed separately after all other
|
|
|
2119 -- specs, and relevant bodies are examined in Process_Main.
|
|
|
2120
|
|
|
2121 when N_Subprogram_Body =>
|
|
|
2122 if Acts_As_Spec (N) then
|
|
|
2123 Do_Unit_And_Dependents (CU, N);
|
|
|
2124 end if;
|
|
|
2125
|
|
|
2126 when N_Package_Body =>
|
|
|
2127 if CU = Main_CU
|
|
|
2128 and then Nkind (Original_Node (Unit (Main_CU))) in
|
|
|
2129 N_Generic_Instantiation
|
|
|
2130 and then Present (Library_Unit (Main_CU))
|
|
|
2131 then
|
|
|
2132 Do_Unit_And_Dependents
|
|
|
2133 (Library_Unit (Main_CU),
|
|
|
2134 Unit (Library_Unit (Main_CU)));
|
|
|
2135 end if;
|
|
|
2136
|
|
|
2137 -- It is a spec, process it, and the units it depends on,
|
|
|
2138 -- unless it is a descendant of the main unit. This can happen
|
|
|
2139 -- when the body of a parent depends on some other descendant.
|
|
|
2140
|
|
|
2141 when N_Null_Statement =>
|
|
|
2142
|
|
|
2143 -- Ignore an ignored ghost unit
|
|
|
2144
|
|
|
2145 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N)));
|
|
|
2146 null;
|
|
|
2147
|
|
|
2148 when others =>
|
|
|
2149 Par := Scope (Defining_Entity (Unit (CU)));
|
|
|
2150
|
|
|
2151 if Is_Child_Unit (Defining_Entity (Unit (CU))) then
|
|
|
2152 while Present (Par)
|
|
|
2153 and then Par /= Standard_Standard
|
|
|
2154 and then Par /= Cunit_Entity (Main_Unit)
|
|
|
2155 loop
|
|
|
2156 Par := Scope (Par);
|
|
|
2157 end loop;
|
|
|
2158 end if;
|
|
|
2159
|
|
|
2160 if Par /= Cunit_Entity (Main_Unit) then
|
|
|
2161 Do_Unit_And_Dependents (CU, N);
|
|
|
2162 end if;
|
|
131
|
2163
|
|
111
|
2164 end case;
|
|
|
2165 end;
|
|
|
2166
|
|
|
2167 Next_Elmt (Cur);
|
|
|
2168 end loop;
|
|
|
2169
|
|
|
2170 -- Now process package bodies on which main depends, followed by bodies
|
|
|
2171 -- of parents, if present, and finally main itself.
|
|
|
2172
|
|
|
2173 if not Done (Main_Unit) then
|
|
|
2174 Do_Main := True;
|
|
|
2175
|
|
|
2176 Process_Main : declare
|
|
|
2177 Parent_CU : Node_Id;
|
|
|
2178 Body_CU : Node_Id;
|
|
|
2179 Body_U : Unit_Number_Type;
|
|
|
2180 Child : Entity_Id;
|
|
|
2181
|
|
|
2182 function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
|
|
|
2183 -- If the main unit has subunits, their context may include
|
|
|
2184 -- bodies that are needed in the body of main. We must examine
|
|
|
2185 -- the context of the subunits, which are otherwise not made
|
|
|
2186 -- explicit in the main unit.
|
|
|
2187
|
|
|
2188 ------------------------
|
|
|
2189 -- Is_Subunit_Of_Main --
|
|
|
2190 ------------------------
|
|
|
2191
|
|
|
2192 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
|
|
|
2193 Lib : Node_Id;
|
|
131
|
2194
|
|
111
|
2195 begin
|
|
131
|
2196 if Present (U) and then Nkind (Unit (U)) = N_Subunit then
|
|
111
|
2197 Lib := Library_Unit (U);
|
|
131
|
2198 return Lib = Main_CU or else Is_Subunit_Of_Main (Lib);
|
|
|
2199 else
|
|
|
2200 return False;
|
|
111
|
2201 end if;
|
|
|
2202 end Is_Subunit_Of_Main;
|
|
|
2203
|
|
|
2204 -- Start of processing for Process_Main
|
|
|
2205
|
|
|
2206 begin
|
|
|
2207 Process_Bodies_In_Context (Main_CU);
|
|
|
2208
|
|
|
2209 for Unit_Num in Done'Range loop
|
|
|
2210 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
|
|
|
2211 Process_Bodies_In_Context (Cunit (Unit_Num));
|
|
|
2212 end if;
|
|
|
2213 end loop;
|
|
|
2214
|
|
|
2215 -- If the main unit is a child unit, parent bodies may be present
|
|
|
2216 -- because they export instances or inlined subprograms. Check for
|
|
|
2217 -- presence of these, which are not present in context clauses.
|
|
|
2218 -- Note that if the parents are instances, their bodies have been
|
|
|
2219 -- processed before the main spec, because they may be needed
|
|
|
2220 -- therein, so the following loop only affects non-instances.
|
|
|
2221
|
|
|
2222 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
|
|
|
2223 Child := Cunit_Entity (Main_Unit);
|
|
|
2224 while Is_Child_Unit (Child) loop
|
|
|
2225 Parent_CU :=
|
|
|
2226 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
|
|
|
2227 Body_CU := Library_Unit (Parent_CU);
|
|
|
2228
|
|
|
2229 if Present (Body_CU)
|
|
|
2230 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
|
|
|
2231 and then not Depends_On_Main (Body_CU)
|
|
|
2232 then
|
|
|
2233 Body_U := Get_Cunit_Unit_Number (Body_CU);
|
|
|
2234 Seen (Body_U) := True;
|
|
|
2235 Do_Action (Body_CU, Unit (Body_CU));
|
|
|
2236 Done (Body_U) := True;
|
|
|
2237 end if;
|
|
|
2238
|
|
|
2239 Child := Scope (Child);
|
|
|
2240 end loop;
|
|
|
2241 end if;
|
|
|
2242
|
|
|
2243 Do_Action (Main_CU, Unit (Main_CU));
|
|
|
2244 Done (Main_Unit) := True;
|
|
|
2245 end Process_Main;
|
|
|
2246 end if;
|
|
|
2247
|
|
|
2248 if Debug_Unit_Walk then
|
|
|
2249 if Done /= (Done'Range => True) then
|
|
|
2250 Write_Eol;
|
|
|
2251 Write_Line ("Ignored units:");
|
|
|
2252
|
|
|
2253 Indent;
|
|
|
2254
|
|
|
2255 for Unit_Num in Done'Range loop
|
|
|
2256 if not Done (Unit_Num) then
|
|
131
|
2257
|
|
|
2258 -- Units with configuration pragmas (.ads files) have empty
|
|
|
2259 -- compilation-unit nodes; skip printing info about them.
|
|
|
2260
|
|
|
2261 if Present (Cunit (Unit_Num)) then
|
|
|
2262 Write_Unit_Info
|
|
|
2263 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
|
|
|
2264 end if;
|
|
111
|
2265 end if;
|
|
|
2266 end loop;
|
|
|
2267
|
|
|
2268 Outdent;
|
|
|
2269 end if;
|
|
|
2270 end if;
|
|
|
2271
|
|
|
2272 pragma Assert (Done (Main_Unit));
|
|
|
2273
|
|
|
2274 if Debug_Unit_Walk then
|
|
|
2275 Outdent;
|
|
|
2276 Write_Line ("end Walk_Library_Items.");
|
|
|
2277 end if;
|
|
|
2278 end Walk_Library_Items;
|
|
|
2279
|
|
|
2280 ----------------
|
|
|
2281 -- Walk_Withs --
|
|
|
2282 ----------------
|
|
|
2283
|
|
|
2284 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
|
|
|
2285 pragma Assert (Nkind (CU) = N_Compilation_Unit);
|
|
|
2286 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
|
|
|
2287
|
|
|
2288 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
|
|
|
2289
|
|
|
2290 begin
|
|
|
2291 -- First walk the withs immediately on the library item
|
|
|
2292
|
|
|
2293 Walk_Immediate (CU, Include_Limited);
|
|
|
2294
|
|
|
2295 -- For a body, we must also check for any subunits which belong to it
|
|
|
2296 -- and which have context clauses of their own, since these with'ed
|
|
|
2297 -- units are part of its own dependencies.
|
|
|
2298
|
|
|
2299 if Nkind (Unit (CU)) in N_Unit_Body then
|
|
|
2300 for S in Main_Unit .. Last_Unit loop
|
|
|
2301
|
|
|
2302 -- We are only interested in subunits. For preproc. data and def.
|
|
|
2303 -- files, Cunit is Empty, so we need to test that first.
|
|
|
2304
|
|
|
2305 if Cunit (S) /= Empty
|
|
|
2306 and then Nkind (Unit (Cunit (S))) = N_Subunit
|
|
|
2307 then
|
|
|
2308 declare
|
|
|
2309 Pnode : Node_Id;
|
|
|
2310
|
|
|
2311 begin
|
|
|
2312 Pnode := Library_Unit (Cunit (S));
|
|
|
2313
|
|
|
2314 -- In -gnatc mode, the errors in the subunits will not have
|
|
|
2315 -- been recorded, but the analysis of the subunit may have
|
|
|
2316 -- failed, so just quit.
|
|
|
2317
|
|
|
2318 if No (Pnode) then
|
|
|
2319 exit;
|
|
|
2320 end if;
|
|
|
2321
|
|
|
2322 -- Find ultimate parent of the subunit
|
|
|
2323
|
|
|
2324 while Nkind (Unit (Pnode)) = N_Subunit loop
|
|
|
2325 Pnode := Library_Unit (Pnode);
|
|
|
2326 end loop;
|
|
|
2327
|
|
|
2328 -- See if it belongs to current unit, and if so, include its
|
|
|
2329 -- with_clauses. Do not process main unit prematurely.
|
|
|
2330
|
|
|
2331 if Pnode = CU and then CU /= Cunit (Main_Unit) then
|
|
|
2332 Walk_Immediate (Cunit (S), Include_Limited);
|
|
|
2333 end if;
|
|
|
2334 end;
|
|
|
2335 end if;
|
|
|
2336 end loop;
|
|
|
2337 end if;
|
|
|
2338 end Walk_Withs;
|
|
|
2339
|
|
|
2340 --------------------------
|
|
|
2341 -- Walk_Withs_Immediate --
|
|
|
2342 --------------------------
|
|
|
2343
|
|
|
2344 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
|
|
|
2345 pragma Assert (Nkind (CU) = N_Compilation_Unit);
|
|
|
2346
|
|
|
2347 Context_Item : Node_Id;
|
|
|
2348 Lib_Unit : Node_Id;
|
|
|
2349
|
|
|
2350 begin
|
|
|
2351 Context_Item := First (Context_Items (CU));
|
|
|
2352 while Present (Context_Item) loop
|
|
|
2353 if Nkind (Context_Item) = N_With_Clause
|
|
|
2354 and then (Include_Limited
|
|
|
2355 or else not Limited_Present (Context_Item))
|
|
|
2356 then
|
|
|
2357 Lib_Unit := Library_Unit (Context_Item);
|
|
|
2358 Action (Lib_Unit);
|
|
|
2359 end if;
|
|
|
2360
|
|
|
2361 Context_Item := Next (Context_Item);
|
|
|
2362 end loop;
|
|
|
2363 end Walk_Withs_Immediate;
|
|
|
2364
|
|
|
2365 end Sem;
|
