OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.