gcc/ada/sem.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  S E M                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Debug_A;  use Debug_A;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Expander; use Expander;
  33 with Fname;    use Fname;
  34 with HLO;      use HLO;
  35 with Lib;      use Lib;
  36 with Lib.Load; use Lib.Load;
  37 with Nlists;   use Nlists;
  38 with Opt;      use Opt;
  39 with Sem_Attr; use Sem_Attr;
  40 with Sem_Ch2;  use Sem_Ch2;
  41 with Sem_Ch3;  use Sem_Ch3;
  42 with Sem_Ch4;  use Sem_Ch4;
  43 with Sem_Ch5;  use Sem_Ch5;
  44 with Sem_Ch6;  use Sem_Ch6;
  45 with Sem_Ch7;  use Sem_Ch7;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Ch9;  use Sem_Ch9;
  48 with Sem_Ch10; use Sem_Ch10;
  49 with Sem_Ch11; use Sem_Ch11;
  50 with Sem_Ch12; use Sem_Ch12;
  51 with Sem_Ch13; use Sem_Ch13;
  52 with Sem_Prag; use Sem_Prag;
  53 with Sem_Util; use Sem_Util;
  54 with Sinfo;    use Sinfo;
  55 with Stand;    use Stand;
  56 with Uintp;    use Uintp;
  57
  58 pragma Warnings (Off, Sem_Util);
  59 --  Suppress warnings of unused with for Sem_Util (used only in asserts)
  60
  61 package body Sem is
  62
  63    Outer_Generic_Scope : Entity_Id := Empty;
  64    --  Global reference to the outer scope that is generic. In a non
  65    --  generic context, it is empty. At the moment, it is only used
  66    --  for avoiding freezing of external references in generics.
  67
  68    -------------
  69    -- Analyze --
  70    -------------
  71
  72    procedure Analyze (N : Node_Id) is
  73    begin
  74       Debug_A_Entry ("analyzing  ", N);
  75
  76       --  Immediate return if already analyzed
  77
  78       if Analyzed (N) then
  79          Debug_A_Exit ("analyzing  ", N, "  (done, analyzed already)");
  80          return;
  81       end if;
  82
  83       --  Otherwise processing depends on the node kind
  84
  85       case Nkind (N) is
  86
  87          when N_Abort_Statement =>
  88             Analyze_Abort_Statement (N);
  89
  90          when N_Abstract_Subprogram_Declaration =>
  91             Analyze_Abstract_Subprogram_Declaration (N);
  92
  93          when N_Accept_Alternative =>
  94             Analyze_Accept_Alternative (N);
  95
  96          when N_Accept_Statement =>
  97             Analyze_Accept_Statement (N);
  98
  99          when N_Aggregate =>
 100             Analyze_Aggregate (N);
 101
 102          when N_Allocator =>
 103             Analyze_Allocator (N);
 104
 105          when N_And_Then =>
 106             Analyze_Short_Circuit (N);
 107
 108          when N_Assignment_Statement =>
 109             Analyze_Assignment (N);
 110
 111          when N_Asynchronous_Select =>
 112             Analyze_Asynchronous_Select (N);
 113
 114          when N_At_Clause =>
 115             Analyze_At_Clause (N);
 116
 117          when N_Attribute_Reference =>
 118             Analyze_Attribute (N);
 119
 120          when N_Attribute_Definition_Clause   =>
 121             Analyze_Attribute_Definition_Clause (N);
 122
 123          when N_Block_Statement =>
 124             Analyze_Block_Statement (N);
 125
 126          when N_Case_Statement =>
 127             Analyze_Case_Statement (N);
 128
 129          when N_Character_Literal =>
 130             Analyze_Character_Literal (N);
 131
 132          when N_Code_Statement =>
 133             Analyze_Code_Statement (N);
 134
 135          when N_Compilation_Unit =>
 136             Analyze_Compilation_Unit (N);
 137
 138          when N_Component_Declaration =>
 139             Analyze_Component_Declaration (N);
 140
 141          when N_Conditional_Expression =>
 142             Analyze_Conditional_Expression (N);
 143
 144          when N_Conditional_Entry_Call =>
 145             Analyze_Conditional_Entry_Call (N);
 146
 147          when N_Delay_Alternative =>
 148             Analyze_Delay_Alternative (N);
 149
 150          when N_Delay_Relative_Statement =>
 151             Analyze_Delay_Relative (N);
 152
 153          when N_Delay_Until_Statement =>
 154             Analyze_Delay_Until (N);
 155
 156          when N_Entry_Body =>
 157             Analyze_Entry_Body (N);
 158
 159          when N_Entry_Body_Formal_Part =>
 160             Analyze_Entry_Body_Formal_Part (N);
 161
 162          when N_Entry_Call_Alternative =>
 163             Analyze_Entry_Call_Alternative (N);
 164
 165          when N_Entry_Declaration =>
 166             Analyze_Entry_Declaration (N);
 167
 168          when N_Entry_Index_Specification     =>
 169             Analyze_Entry_Index_Specification (N);
 170
 171          when N_Enumeration_Representation_Clause =>
 172             Analyze_Enumeration_Representation_Clause (N);
 173
 174          when N_Exception_Declaration =>
 175             Analyze_Exception_Declaration (N);
 176
 177          when N_Exception_Renaming_Declaration =>
 178             Analyze_Exception_Renaming (N);
 179
 180          when N_Exit_Statement =>
 181             Analyze_Exit_Statement (N);
 182
 183          when N_Expanded_Name =>
 184             Analyze_Expanded_Name (N);
 185
 186          when N_Explicit_Dereference =>
 187             Analyze_Explicit_Dereference (N);
 188
 189          when N_Extension_Aggregate =>
 190             Analyze_Aggregate (N);
 191
 192          when N_Formal_Object_Declaration =>
 193             Analyze_Formal_Object_Declaration (N);
 194
 195          when N_Formal_Package_Declaration =>
 196             Analyze_Formal_Package (N);
 197
 198          when N_Formal_Subprogram_Declaration =>
 199             Analyze_Formal_Subprogram (N);
 200
 201          when N_Formal_Type_Declaration =>
 202             Analyze_Formal_Type_Declaration (N);
 203
 204          when N_Free_Statement =>
 205             Analyze_Free_Statement (N);
 206
 207          when N_Freeze_Entity =>
 208             null;  -- no semantic processing required
 209
 210          when N_Full_Type_Declaration =>
 211             Analyze_Type_Declaration (N);
 212
 213          when N_Function_Call =>
 214             Analyze_Function_Call (N);
 215
 216          when N_Function_Instantiation =>
 217             Analyze_Function_Instantiation (N);
 218
 219          when N_Generic_Function_Renaming_Declaration =>
 220             Analyze_Generic_Function_Renaming (N);
 221
 222          when N_Generic_Package_Declaration =>
 223             Analyze_Generic_Package_Declaration (N);
 224
 225          when N_Generic_Package_Renaming_Declaration =>
 226             Analyze_Generic_Package_Renaming (N);
 227
 228          when N_Generic_Procedure_Renaming_Declaration =>
 229             Analyze_Generic_Procedure_Renaming (N);
 230
 231          when N_Generic_Subprogram_Declaration =>
 232             Analyze_Generic_Subprogram_Declaration (N);
 233
 234          when N_Goto_Statement =>
 235             Analyze_Goto_Statement (N);
 236
 237          when N_Handled_Sequence_Of_Statements =>
 238             Analyze_Handled_Statements (N);
 239
 240          when N_Identifier =>
 241             Analyze_Identifier (N);
 242
 243          when N_If_Statement =>
 244             Analyze_If_Statement (N);
 245
 246          when N_Implicit_Label_Declaration =>
 247             Analyze_Implicit_Label_Declaration (N);
 248
 249          when N_In =>
 250             Analyze_Membership_Op (N);
 251
 252          when N_Incomplete_Type_Declaration =>
 253             Analyze_Incomplete_Type_Decl (N);
 254
 255          when N_Indexed_Component =>
 256             Analyze_Indexed_Component_Form (N);
 257
 258          when N_Integer_Literal =>
 259             Analyze_Integer_Literal (N);
 260
 261          when N_Itype_Reference =>
 262             Analyze_Itype_Reference (N);
 263
 264          when N_Label =>
 265             Analyze_Label (N);
 266
 267          when N_Loop_Statement =>
 268             Analyze_Loop_Statement (N);
 269
 270          when N_Not_In =>
 271             Analyze_Membership_Op (N);
 272
 273          when N_Null =>
 274             Analyze_Null (N);
 275
 276          when N_Null_Statement =>
 277             Analyze_Null_Statement (N);
 278
 279          when N_Number_Declaration =>
 280             Analyze_Number_Declaration (N);
 281
 282          when N_Object_Declaration =>
 283             Analyze_Object_Declaration (N);
 284
 285          when N_Object_Renaming_Declaration  =>
 286             Analyze_Object_Renaming (N);
 287
 288          when N_Operator_Symbol =>
 289             Analyze_Operator_Symbol (N);
 290
 291          when N_Op_Abs =>
 292             Analyze_Unary_Op (N);
 293
 294          when N_Op_Add =>
 295             Analyze_Arithmetic_Op (N);
 296
 297          when N_Op_And =>
 298             Analyze_Logical_Op (N);
 299
 300          when N_Op_Concat =>
 301             Analyze_Concatenation (N);
 302
 303          when N_Op_Divide =>
 304             Analyze_Arithmetic_Op (N);
 305
 306          when N_Op_Eq =>
 307             Analyze_Equality_Op (N);
 308
 309          when N_Op_Expon =>
 310             Analyze_Arithmetic_Op (N);
 311
 312          when N_Op_Ge =>
 313             Analyze_Comparison_Op (N);
 314
 315          when N_Op_Gt =>
 316             Analyze_Comparison_Op (N);
 317
 318          when N_Op_Le =>
 319             Analyze_Comparison_Op (N);
 320
 321          when N_Op_Lt =>
 322             Analyze_Comparison_Op (N);
 323
 324          when N_Op_Minus =>
 325             Analyze_Unary_Op (N);
 326
 327          when N_Op_Mod =>
 328             Analyze_Arithmetic_Op (N);
 329
 330          when N_Op_Multiply =>
 331             Analyze_Arithmetic_Op (N);
 332
 333          when N_Op_Ne =>
 334             Analyze_Equality_Op (N);
 335
 336          when N_Op_Not =>
 337             Analyze_Negation (N);
 338
 339          when N_Op_Or =>
 340             Analyze_Logical_Op (N);
 341
 342          when N_Op_Plus =>
 343             Analyze_Unary_Op (N);
 344
 345          when N_Op_Rem =>
 346             Analyze_Arithmetic_Op (N);
 347
 348          when N_Op_Rotate_Left =>
 349             Analyze_Arithmetic_Op (N);
 350
 351          when N_Op_Rotate_Right =>
 352             Analyze_Arithmetic_Op (N);
 353
 354          when N_Op_Shift_Left =>
 355             Analyze_Arithmetic_Op (N);
 356
 357          when N_Op_Shift_Right =>
 358             Analyze_Arithmetic_Op (N);
 359
 360          when N_Op_Shift_Right_Arithmetic =>
 361             Analyze_Arithmetic_Op (N);
 362
 363          when N_Op_Subtract =>
 364             Analyze_Arithmetic_Op (N);
 365
 366          when N_Op_Xor =>
 367             Analyze_Logical_Op (N);
 368
 369          when N_Or_Else =>
 370             Analyze_Short_Circuit (N);
 371
 372          when N_Others_Choice =>
 373             Analyze_Others_Choice (N);
 374
 375          when N_Package_Body =>
 376             Analyze_Package_Body (N);
 377
 378          when N_Package_Body_Stub =>
 379             Analyze_Package_Body_Stub (N);
 380
 381          when N_Package_Declaration =>
 382             Analyze_Package_Declaration (N);
 383
 384          when N_Package_Instantiation =>
 385             Analyze_Package_Instantiation (N);
 386
 387          when N_Package_Renaming_Declaration =>
 388             Analyze_Package_Renaming (N);
 389
 390          when N_Package_Specification =>
 391             Analyze_Package_Specification (N);
 392
 393          when N_Parameter_Association =>
 394             Analyze_Parameter_Association (N);
 395
 396          when N_Pragma =>
 397             Analyze_Pragma (N);
 398
 399          when N_Private_Extension_Declaration =>
 400             Analyze_Private_Extension_Declaration (N);
 401
 402          when N_Private_Type_Declaration =>
 403             Analyze_Private_Type_Declaration (N);
 404
 405          when N_Procedure_Call_Statement =>
 406             Analyze_Procedure_Call (N);
 407
 408          when N_Procedure_Instantiation =>
 409             Analyze_Procedure_Instantiation (N);
 410
 411          when N_Protected_Body =>
 412             Analyze_Protected_Body (N);
 413
 414          when N_Protected_Body_Stub =>
 415             Analyze_Protected_Body_Stub (N);
 416
 417          when N_Protected_Definition =>
 418             Analyze_Protected_Definition (N);
 419
 420          when N_Protected_Type_Declaration =>
 421             Analyze_Protected_Type (N);
 422
 423          when N_Qualified_Expression =>
 424             Analyze_Qualified_Expression (N);
 425
 426          when N_Raise_Statement =>
 427             Analyze_Raise_Statement (N);
 428
 429          when N_Raise_xxx_Error =>
 430             Analyze_Raise_xxx_Error (N);
 431
 432          when N_Range =>
 433             Analyze_Range (N);
 434
 435          when N_Range_Constraint =>
 436             Analyze_Range (Range_Expression (N));
 437
 438          when N_Real_Literal =>
 439             Analyze_Real_Literal (N);
 440
 441          when N_Record_Representation_Clause =>
 442             Analyze_Record_Representation_Clause (N);
 443
 444          when N_Reference =>
 445             Analyze_Reference (N);
 446
 447          when N_Requeue_Statement =>
 448             Analyze_Requeue (N);
 449
 450          when N_Return_Statement =>
 451             Analyze_Return_Statement (N);
 452
 453          when N_Selected_Component =>
 454             Find_Selected_Component (N);
 455             --  ??? why not Analyze_Selected_Component, needs comments
 456
 457          when N_Selective_Accept =>
 458             Analyze_Selective_Accept (N);
 459
 460          when N_Single_Protected_Declaration =>
 461             Analyze_Single_Protected (N);
 462
 463          when N_Single_Task_Declaration =>
 464             Analyze_Single_Task (N);
 465
 466          when N_Slice =>
 467             Analyze_Slice (N);
 468
 469          when N_String_Literal =>
 470             Analyze_String_Literal (N);
 471
 472          when N_Subprogram_Body =>
 473             Analyze_Subprogram_Body (N);
 474
 475          when N_Subprogram_Body_Stub =>
 476             Analyze_Subprogram_Body_Stub (N);
 477
 478          when N_Subprogram_Declaration =>
 479             Analyze_Subprogram_Declaration (N);
 480
 481          when N_Subprogram_Info =>
 482             Analyze_Subprogram_Info (N);
 483
 484          when N_Subprogram_Renaming_Declaration =>
 485             Analyze_Subprogram_Renaming (N);
 486
 487          when N_Subtype_Declaration =>
 488             Analyze_Subtype_Declaration (N);
 489
 490          when N_Subtype_Indication =>
 491             Analyze_Subtype_Indication (N);
 492
 493          when N_Subunit =>
 494             Analyze_Subunit (N);
 495
 496          when N_Task_Body =>
 497             Analyze_Task_Body (N);
 498
 499          when N_Task_Body_Stub =>
 500             Analyze_Task_Body_Stub (N);
 501
 502          when N_Task_Definition =>
 503             Analyze_Task_Definition (N);
 504
 505          when N_Task_Type_Declaration =>
 506             Analyze_Task_Type (N);
 507
 508          when N_Terminate_Alternative =>
 509             Analyze_Terminate_Alternative (N);
 510
 511          when N_Timed_Entry_Call =>
 512             Analyze_Timed_Entry_Call (N);
 513
 514          when N_Triggering_Alternative =>
 515             Analyze_Triggering_Alternative (N);
 516
 517          when N_Type_Conversion =>
 518             Analyze_Type_Conversion (N);
 519
 520          when N_Unchecked_Expression =>
 521             Analyze_Unchecked_Expression (N);
 522
 523          when N_Unchecked_Type_Conversion =>
 524             Analyze_Unchecked_Type_Conversion (N);
 525
 526          when N_Use_Package_Clause =>
 527             Analyze_Use_Package (N);
 528
 529          when N_Use_Type_Clause =>
 530             Analyze_Use_Type (N);
 531
 532          when N_Validate_Unchecked_Conversion =>
 533             null;
 534
 535          when N_Variant_Part =>
 536             Analyze_Variant_Part (N);
 537
 538          when N_With_Clause =>
 539             Analyze_With_Clause (N);
 540
 541          when N_With_Type_Clause =>
 542             Analyze_With_Type_Clause (N);
 543
 544          --  A call to analyze the Empty node is an error, but most likely
 545          --  it is an error caused by an attempt to analyze a malformed
 546          --  piece of tree caused by some other error, so if there have
 547          --  been any other errors, we just ignore it, otherwise it is
 548          --  a real internal error which we complain about.
 549
 550          when N_Empty =>
 551             pragma Assert (Serious_Errors_Detected /= 0);
 552             null;
 553
 554          --  A call to analyze the error node is simply ignored, to avoid
 555          --  causing cascaded errors (happens of course only in error cases)
 556
 557          when N_Error =>
 558             null;
 559
 560          --  For the remaining node types, we generate compiler abort, because
 561          --  these nodes are always analyzed within the Sem_Chn routines and
 562          --  there should never be a case of making a call to the main Analyze
 563          --  routine for these node kinds. For example, an N_Access_Definition
 564          --  node appears only in the context of a type declaration, and is
 565          --  processed by the analyze routine for type declarations.
 566
 567          when
 568            N_Abortable_Part                         |
 569            N_Access_Definition                      |
 570            N_Access_Function_Definition             |
 571            N_Access_Procedure_Definition            |
 572            N_Access_To_Object_Definition            |
 573            N_Case_Statement_Alternative             |
 574            N_Compilation_Unit_Aux                   |
 575            N_Component_Association                  |
 576            N_Component_Clause                       |
 577            N_Component_Definition                   |
 578            N_Component_List                         |
 579            N_Constrained_Array_Definition           |
 580            N_Decimal_Fixed_Point_Definition         |
 581            N_Defining_Character_Literal             |
 582            N_Defining_Identifier                    |
 583            N_Defining_Operator_Symbol               |
 584            N_Defining_Program_Unit_Name             |
 585            N_Delta_Constraint                       |
 586            N_Derived_Type_Definition                |
 587            N_Designator                             |
 588            N_Digits_Constraint                      |
 589            N_Discriminant_Association               |
 590            N_Discriminant_Specification             |
 591            N_Elsif_Part                             |
 592            N_Entry_Call_Statement                   |
 593            N_Enumeration_Type_Definition            |
 594            N_Exception_Handler                      |
 595            N_Floating_Point_Definition              |
 596            N_Formal_Decimal_Fixed_Point_Definition  |
 597            N_Formal_Derived_Type_Definition         |
 598            N_Formal_Discrete_Type_Definition        |
 599            N_Formal_Floating_Point_Definition       |
 600            N_Formal_Modular_Type_Definition         |
 601            N_Formal_Ordinary_Fixed_Point_Definition |
 602            N_Formal_Private_Type_Definition         |
 603            N_Formal_Signed_Integer_Type_Definition  |
 604            N_Function_Specification                 |
 605            N_Generic_Association                    |
 606            N_Index_Or_Discriminant_Constraint       |
 607            N_Iteration_Scheme                       |
 608            N_Loop_Parameter_Specification           |
 609            N_Mod_Clause                             |
 610            N_Modular_Type_Definition                |
 611            N_Ordinary_Fixed_Point_Definition        |
 612            N_Parameter_Specification                |
 613            N_Pragma_Argument_Association            |
 614            N_Procedure_Specification                |
 615            N_Real_Range_Specification               |
 616            N_Record_Definition                      |
 617            N_Signed_Integer_Type_Definition         |
 618            N_Unconstrained_Array_Definition         |
 619            N_Unused_At_Start                        |
 620            N_Unused_At_End                          |
 621            N_Variant                                =>
 622
 623             raise Program_Error;
 624       end case;
 625
 626       Debug_A_Exit ("analyzing  ", N, "  (done)");
 627
 628       --  Now that we have analyzed the node, we call the expander to
 629       --  perform possible expansion. This is done only for nodes that
 630       --  are not subexpressions, because in the case of subexpressions,
 631       --  we don't have the type yet, and the expander will need to know
 632       --  the type before it can do its job. For subexpression nodes, the
 633       --  call to the expander happens in the Sem_Res.Resolve.
 634
 635       --  The Analyzed flag is also set at this point for non-subexpression
 636       --  nodes (in the case of subexpression nodes, we can't set the flag
 637       --  yet, since resolution and expansion have not yet been completed)
 638
 639       if Nkind (N) not in N_Subexpr then
 640          Expand (N);
 641       end if;
 642    end Analyze;
 643
 644    --  Version with check(s) suppressed
 645
 646    procedure Analyze (N : Node_Id; Suppress : Check_Id) is
 647    begin
 648       if Suppress = All_Checks then
 649          declare
 650             Svg : constant Suppress_Array := Scope_Suppress;
 651
 652          begin
 653             Scope_Suppress := (others => True);
 654             Analyze (N);
 655             Scope_Suppress := Svg;
 656          end;
 657
 658       else
 659          declare
 660             Svg : constant Boolean := Scope_Suppress (Suppress);
 661
 662          begin
 663             Scope_Suppress (Suppress) := True;
 664             Analyze (N);
 665             Scope_Suppress (Suppress) := Svg;
 666          end;
 667       end if;
 668    end Analyze;
 669
 670    ------------------
 671    -- Analyze_List --
 672    ------------------
 673
 674    procedure Analyze_List (L : List_Id) is
 675       Node : Node_Id;
 676
 677    begin
 678       Node := First (L);
 679       while Present (Node) loop
 680          Analyze (Node);
 681          Next (Node);
 682       end loop;
 683    end Analyze_List;
 684
 685    --  Version with check(s) suppressed
 686
 687    procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
 688    begin
 689       if Suppress = All_Checks then
 690          declare
 691             Svg : constant Suppress_Array := Scope_Suppress;
 692
 693          begin
 694             Scope_Suppress := (others => True);
 695             Analyze_List (L);
 696             Scope_Suppress := Svg;
 697          end;
 698
 699       else
 700          declare
 701             Svg : constant Boolean := Scope_Suppress (Suppress);
 702
 703          begin
 704             Scope_Suppress (Suppress) := True;
 705             Analyze_List (L);
 706             Scope_Suppress (Suppress) := Svg;
 707          end;
 708       end if;
 709    end Analyze_List;
 710
 711    --------------------------
 712    -- Copy_Suppress_Status --
 713    --------------------------
 714
 715    procedure Copy_Suppress_Status
 716      (C    : Check_Id;
 717       From : Entity_Id;
 718       To   : Entity_Id)
 719    is
 720    begin
 721       if not Checks_May_Be_Suppressed (From) then
 722          return;
 723       end if;
 724
 725       --  First search the local entity suppress table, we search this in
 726       --  reverse order so that we get the innermost entry that applies to
 727       --  this case if there are nested entries. Note that for the purpose
 728       --  of this procedure we are ONLY looking for entries corresponding
 729       --  to a two-argument Suppress, where the second argument matches From.
 730
 731       for J in
 732         reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
 733       loop
 734          declare
 735             R : Entity_Check_Suppress_Record
 736                   renames Local_Entity_Suppress.Table (J);
 737
 738          begin
 739             if R.Entity = From
 740               and then (R.Check = All_Checks or else R.Check = C)
 741             then
 742                if R.Suppress then
 743                   Set_Checks_May_Be_Suppressed (To, True);
 744                   Local_Entity_Suppress.Append
 745                     ((Entity   => To,
 746                       Check    => C,
 747                       Suppress => True));
 748                   return;
 749                end if;
 750             end if;
 751          end;
 752       end loop;
 753
 754       --  Now search the global entity suppress table for a matching entry
 755       --  We also search this in reverse order so that if there are multiple
 756       --  pragmas for the same entity, the last one applies.
 757
 758       for J in
 759         reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
 760       loop
 761          declare
 762             R : Entity_Check_Suppress_Record
 763                  renames Global_Entity_Suppress.Table (J);
 764
 765          begin
 766             if R.Entity = From
 767               and then (R.Check = All_Checks or else R.Check = C)
 768             then
 769                if R.Suppress then
 770                   Set_Checks_May_Be_Suppressed (To, True);
 771                   Local_Entity_Suppress.Append
 772                     ((Entity   => To,
 773                       Check    => C,
 774                       Suppress => True));
 775                end if;
 776             end if;
 777          end;
 778       end loop;
 779    end Copy_Suppress_Status;
 780
 781    -------------------------
 782    -- Enter_Generic_Scope --
 783    -------------------------
 784
 785    procedure Enter_Generic_Scope (S : Entity_Id) is
 786    begin
 787       if No (Outer_Generic_Scope) then
 788          Outer_Generic_Scope := S;
 789       end if;
 790    end Enter_Generic_Scope;
 791
 792    ------------------------
 793    -- Exit_Generic_Scope --
 794    ------------------------
 795
 796    procedure Exit_Generic_Scope  (S : Entity_Id) is
 797    begin
 798       if S = Outer_Generic_Scope then
 799          Outer_Generic_Scope := Empty;
 800       end if;
 801    end Exit_Generic_Scope;
 802
 803    -----------------------
 804    -- Explicit_Suppress --
 805    -----------------------
 806
 807    function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
 808    begin
 809       if not Checks_May_Be_Suppressed (E) then
 810          return False;
 811
 812       else
 813          for J in
 814            reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
 815          loop
 816             declare
 817                R : Entity_Check_Suppress_Record
 818                      renames Global_Entity_Suppress.Table (J);
 819
 820             begin
 821                if R.Entity = E
 822                  and then (R.Check = All_Checks or else R.Check = C)
 823                then
 824                   return R.Suppress;
 825                end if;
 826             end;
 827          end loop;
 828
 829          return False;
 830       end if;
 831    end Explicit_Suppress;
 832
 833    -----------------------------
 834    -- External_Ref_In_Generic --
 835    -----------------------------
 836
 837    function External_Ref_In_Generic (E : Entity_Id) return Boolean is
 838       Scop : Entity_Id;
 839
 840    begin
 841       --  Entity is global if defined outside of current outer_generic_scope:
 842       --  Either the entity has a smaller depth that the outer generic, or it
 843       --  is in a different compilation unit, or it is defined within a unit
 844       --  in the same compilation, that is not within the outer_generic.
 845
 846       if No (Outer_Generic_Scope) then
 847          return False;
 848
 849       elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
 850         or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
 851       then
 852          return True;
 853
 854       else
 855          Scop := Scope (E);
 856
 857          while Present (Scop) loop
 858             if Scop = Outer_Generic_Scope then
 859                return False;
 860             elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
 861                return True;
 862             else
 863                Scop := Scope (Scop);
 864             end if;
 865          end loop;
 866
 867          return True;
 868       end if;
 869    end External_Ref_In_Generic;
 870
 871    ----------------
 872    -- Initialize --
 873    ----------------
 874
 875    procedure Initialize is
 876    begin
 877       Local_Entity_Suppress.Init;
 878       Global_Entity_Suppress.Init;
 879       Scope_Stack.Init;
 880       Unloaded_Subunits := False;
 881    end Initialize;
 882
 883    ------------------------------
 884    -- Insert_After_And_Analyze --
 885    ------------------------------
 886
 887    procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
 888       Node : Node_Id;
 889
 890    begin
 891       if Present (M) then
 892
 893          --  If we are not at the end of the list, then the easiest
 894          --  coding is simply to insert before our successor
 895
 896          if Present (Next (N)) then
 897             Insert_Before_And_Analyze (Next (N), M);
 898
 899          --  Case of inserting at the end of the list
 900
 901          else
 902             --  Capture the Node_Id of the node to be inserted. This Node_Id
 903             --  will still be the same after the insert operation.
 904
 905             Node := M;
 906             Insert_After (N, M);
 907
 908             --  Now just analyze from the inserted node to the end of
 909             --  the new list (note that this properly handles the case
 910             --  where any of the analyze calls result in the insertion of
 911             --  nodes after the analyzed node, expecting analysis).
 912
 913             while Present (Node) loop
 914                Analyze (Node);
 915                Mark_Rewrite_Insertion (Node);
 916                Next (Node);
 917             end loop;
 918          end if;
 919       end if;
 920    end Insert_After_And_Analyze;
 921
 922    --  Version with check(s) suppressed
 923
 924    procedure Insert_After_And_Analyze
 925      (N        : Node_Id;
 926       M        : Node_Id;
 927       Suppress : Check_Id)
 928    is
 929    begin
 930       if Suppress = All_Checks then
 931          declare
 932             Svg : constant Suppress_Array := Scope_Suppress;
 933
 934          begin
 935             Scope_Suppress := (others => True);
 936             Insert_After_And_Analyze (N, M);
 937             Scope_Suppress := Svg;
 938          end;
 939
 940       else
 941          declare
 942             Svg : constant Boolean := Scope_Suppress (Suppress);
 943
 944          begin
 945             Scope_Suppress (Suppress) := True;
 946             Insert_After_And_Analyze (N, M);
 947             Scope_Suppress (Suppress) := Svg;
 948          end;
 949       end if;
 950    end Insert_After_And_Analyze;
 951
 952    -------------------------------
 953    -- Insert_Before_And_Analyze --
 954    -------------------------------
 955
 956    procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
 957       Node : Node_Id;
 958
 959    begin
 960       if Present (M) then
 961
 962          --  Capture the Node_Id of the first list node to be inserted.
 963          --  This will still be the first node after the insert operation,
 964          --  since Insert_List_After does not modify the Node_Id values.
 965
 966          Node := M;
 967          Insert_Before (N, M);
 968
 969          --  The insertion does not change the Id's of any of the nodes in
 970          --  the list, and they are still linked, so we can simply loop from
 971          --  the original first node until we meet the node before which the
 972          --  insertion is occurring. Note that this properly handles the case
 973          --  where any of the analyzed nodes insert nodes after themselves,
 974          --  expecting them to get analyzed.
 975
 976          while Node /= N loop
 977             Analyze (Node);
 978             Mark_Rewrite_Insertion (Node);
 979             Next (Node);
 980          end loop;
 981       end if;
 982    end Insert_Before_And_Analyze;
 983
 984    --  Version with check(s) suppressed
 985
 986    procedure Insert_Before_And_Analyze
 987      (N        : Node_Id;
 988       M        : Node_Id;
 989       Suppress : Check_Id)
 990    is
 991    begin
 992       if Suppress = All_Checks then
 993          declare
 994             Svg : constant Suppress_Array := Scope_Suppress;
 995
 996          begin
 997             Scope_Suppress := (others => True);
 998             Insert_Before_And_Analyze (N, M);
 999             Scope_Suppress := Svg;
1000          end;
1001
1002       else
1003          declare
1004             Svg : constant Boolean := Scope_Suppress (Suppress);
1005
1006          begin
1007             Scope_Suppress (Suppress) := True;
1008             Insert_Before_And_Analyze (N, M);
1009             Scope_Suppress (Suppress) := Svg;
1010          end;
1011       end if;
1012    end Insert_Before_And_Analyze;
1013
1014    -----------------------------------
1015    -- Insert_List_After_And_Analyze --
1016    -----------------------------------
1017
1018    procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1019       After : constant Node_Id := Next (N);
1020       Node  : Node_Id;
1021
1022    begin
1023       if Is_Non_Empty_List (L) then
1024
1025          --  Capture the Node_Id of the first list node to be inserted.
1026          --  This will still be the first node after the insert operation,
1027          --  since Insert_List_After does not modify the Node_Id values.
1028
1029          Node := First (L);
1030          Insert_List_After (N, L);
1031
1032          --  Now just analyze from the original first node until we get to
1033          --  the successor of the original insertion point (which may be
1034          --  Empty if the insertion point was at the end of the list). Note
1035          --  that this properly handles the case where any of the analyze
1036          --  calls result in the insertion of nodes after the analyzed
1037          --  node (possibly calling this routine recursively).
1038
1039          while Node /= After loop
1040             Analyze (Node);
1041             Mark_Rewrite_Insertion (Node);
1042             Next (Node);
1043          end loop;
1044       end if;
1045    end Insert_List_After_And_Analyze;
1046
1047    --  Version with check(s) suppressed
1048
1049    procedure Insert_List_After_And_Analyze
1050      (N : Node_Id; L : List_Id; Suppress : Check_Id)
1051    is
1052    begin
1053       if Suppress = All_Checks then
1054          declare
1055             Svg : constant Suppress_Array := Scope_Suppress;
1056
1057          begin
1058             Scope_Suppress := (others => True);
1059             Insert_List_After_And_Analyze (N, L);
1060             Scope_Suppress := Svg;
1061          end;
1062
1063       else
1064          declare
1065             Svg : constant Boolean := Scope_Suppress (Suppress);
1066
1067          begin
1068             Scope_Suppress (Suppress) := True;
1069             Insert_List_After_And_Analyze (N, L);
1070             Scope_Suppress (Suppress) := Svg;
1071          end;
1072       end if;
1073    end Insert_List_After_And_Analyze;
1074
1075    ------------------------------------
1076    -- Insert_List_Before_And_Analyze --
1077    ------------------------------------
1078
1079    procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1080       Node : Node_Id;
1081
1082    begin
1083       if Is_Non_Empty_List (L) then
1084
1085          --  Capture the Node_Id of the first list node to be inserted.
1086          --  This will still be the first node after the insert operation,
1087          --  since Insert_List_After does not modify the Node_Id values.
1088
1089          Node := First (L);
1090          Insert_List_Before (N, L);
1091
1092          --  The insertion does not change the Id's of any of the nodes in
1093          --  the list, and they are still linked, so we can simply loop from
1094          --  the original first node until we meet the node before which the
1095          --  insertion is occurring. Note that this properly handles the case
1096          --  where any of the analyzed nodes insert nodes after themselves,
1097          --  expecting them to get analyzed.
1098
1099          while Node /= N loop
1100             Analyze (Node);
1101             Mark_Rewrite_Insertion (Node);
1102             Next (Node);
1103          end loop;
1104       end if;
1105    end Insert_List_Before_And_Analyze;
1106
1107    --  Version with check(s) suppressed
1108
1109    procedure Insert_List_Before_And_Analyze
1110      (N : Node_Id; L : List_Id; Suppress : Check_Id)
1111    is
1112    begin
1113       if Suppress = All_Checks then
1114          declare
1115             Svg : constant Suppress_Array := Scope_Suppress;
1116
1117          begin
1118             Scope_Suppress := (others => True);
1119             Insert_List_Before_And_Analyze (N, L);
1120             Scope_Suppress := Svg;
1121          end;
1122
1123       else
1124          declare
1125             Svg : constant Boolean := Scope_Suppress (Suppress);
1126
1127          begin
1128             Scope_Suppress (Suppress) := True;
1129             Insert_List_Before_And_Analyze (N, L);
1130             Scope_Suppress (Suppress) := Svg;
1131          end;
1132       end if;
1133    end Insert_List_Before_And_Analyze;
1134
1135    -------------------------
1136    -- Is_Check_Suppressed --
1137    -------------------------
1138
1139    function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1140    begin
1141       --  First search the local entity suppress table, we search this in
1142       --  reverse order so that we get the innermost entry that applies to
1143       --  this case if there are nested entries.
1144
1145       for J in
1146         reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
1147       loop
1148          declare
1149             R : Entity_Check_Suppress_Record
1150                   renames Local_Entity_Suppress.Table (J);
1151
1152          begin
1153             if (R.Entity = Empty or else R.Entity = E)
1154               and then (R.Check = All_Checks or else R.Check = C)
1155             then
1156                return R.Suppress;
1157             end if;
1158          end;
1159       end loop;
1160
1161       --  Now search the global entity suppress table for a matching entry
1162       --  We also search this in reverse order so that if there are multiple
1163       --  pragmas for the same entity, the last one applies (not clear what
1164       --  or whether the RM specifies this handling, but it seems reasonable).
1165
1166       for J in
1167         reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
1168       loop
1169          declare
1170             R : Entity_Check_Suppress_Record
1171                   renames Global_Entity_Suppress.Table (J);
1172
1173          begin
1174             if R.Entity = E
1175               and then (R.Check = All_Checks or else R.Check = C)
1176             then
1177                return R.Suppress;
1178             end if;
1179          end;
1180       end loop;
1181
1182       --  If we did not find a matching entry, then use the normal scope
1183       --  suppress value after all (actually this will be the global setting
1184       --  since it clearly was not overridden at any point)
1185
1186       return Scope_Suppress (C);
1187    end Is_Check_Suppressed;
1188
1189    ----------
1190    -- Lock --
1191    ----------
1192
1193    procedure Lock is
1194    begin
1195       Local_Entity_Suppress.Locked := True;
1196       Global_Entity_Suppress.Locked := True;
1197       Scope_Stack.Locked := True;
1198       Local_Entity_Suppress.Release;
1199       Global_Entity_Suppress.Release;
1200       Scope_Stack.Release;
1201    end Lock;
1202
1203    ---------------
1204    -- Semantics --
1205    ---------------
1206
1207    procedure Semantics (Comp_Unit : Node_Id) is
1208
1209       --  The following locations save the corresponding global flags and
1210       --  variables so that they can be restored on completion. This is
1211       --  needed so that calls to Rtsfind start with the proper default
1212       --  values for these variables, and also that such calls do not
1213       --  disturb the settings for units being analyzed at a higher level.
1214
1215       S_Full_Analysis    : constant Boolean          := Full_Analysis;
1216       S_In_Default_Expr  : constant Boolean          := In_Default_Expression;
1217       S_Inside_A_Generic : constant Boolean          := Inside_A_Generic;
1218       S_New_Nodes_OK     : constant Int              := New_Nodes_OK;
1219       S_Outer_Gen_Scope  : constant Entity_Id        := Outer_Generic_Scope;
1220       S_Sem_Unit         : constant Unit_Number_Type := Current_Sem_Unit;
1221       S_GNAT_Mode        : constant Boolean          := GNAT_Mode;
1222       Generic_Main       : constant Boolean :=
1223                              Nkind (Unit (Cunit (Main_Unit)))
1224                                in N_Generic_Declaration;
1225
1226       --  If the main unit is generic, every compiled unit, including its
1227       --  context, is compiled with expansion disabled.
1228
1229       Save_Config_Switches : Config_Switches_Type;
1230       --  Variable used to save values of config switches while we analyze
1231       --  the new unit, to be restored on exit for proper recursive behavior.
1232
1233       procedure Do_Analyze;
1234       --  Procedure to analyze the compilation unit. This is called more
1235       --  than once when the high level optimizer is activated.
1236
1237       ----------------
1238       -- Do_Analyze --
1239       ----------------
1240
1241       procedure Do_Analyze is
1242       begin
1243          Save_Scope_Stack;
1244          New_Scope (Standard_Standard);
1245          Scope_Suppress := Suppress_Options;
1246          Scope_Stack.Table
1247            (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1248          Scope_Stack.Table
1249            (Scope_Stack.Last).Is_Active_Stack_Base := True;
1250          Outer_Generic_Scope := Empty;
1251
1252          --  Now analyze the top level compilation unit node
1253
1254          Analyze (Comp_Unit);
1255
1256          --  Check for scope mismatch on exit from compilation
1257
1258          pragma Assert (Current_Scope = Standard_Standard
1259                           or else Comp_Unit = Cunit (Main_Unit));
1260
1261          --  Then pop entry for Standard, and pop implicit types
1262
1263          Pop_Scope;
1264          Restore_Scope_Stack;
1265       end Do_Analyze;
1266
1267    --  Start of processing for Semantics
1268
1269    begin
1270       Compiler_State   := Analyzing;
1271       Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1272
1273       --  Compile predefined units with GNAT_Mode set to True, to properly
1274       --  process the categorization stuff. However, do not set set GNAT_Mode
1275       --  to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1276       --  Sequential_IO) as this would prevent pragma System_Extend to be
1277       --  taken into account, for example when Text_IO is renaming DEC.Text_IO.
1278
1279       --  Cleaner might be to do the kludge at the point of excluding the
1280       --  pragma (do not exclude for renamings ???)
1281
1282       GNAT_Mode :=
1283         GNAT_Mode
1284           or else Is_Predefined_File_Name
1285                     (Unit_File_Name (Current_Sem_Unit),
1286                      Renamings_Included => False);
1287
1288       if Generic_Main then
1289          Expander_Mode_Save_And_Set (False);
1290       else
1291          Expander_Mode_Save_And_Set
1292            (Operating_Mode = Generate_Code or Debug_Flag_X);
1293       end if;
1294
1295       Full_Analysis         := True;
1296       Inside_A_Generic      := False;
1297       In_Default_Expression := False;
1298
1299       Set_Comes_From_Source_Default (False);
1300       Save_Opt_Config_Switches (Save_Config_Switches);
1301       Set_Opt_Config_Switches
1302         (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)));
1303
1304       --  Only do analysis of unit that has not already been analyzed
1305
1306       if not Analyzed (Comp_Unit) then
1307          Initialize_Version (Current_Sem_Unit);
1308          if HLO_Active then
1309             Expander_Mode_Save_And_Set (False);
1310             New_Nodes_OK := 1;
1311             Do_Analyze;
1312             Reset_Analyzed_Flags (Comp_Unit);
1313             Expander_Mode_Restore;
1314             High_Level_Optimize (Comp_Unit);
1315             New_Nodes_OK := 0;
1316          end if;
1317
1318          Do_Analyze;
1319       end if;
1320
1321       --  Save indication of dynamic elaboration checks for ALI file
1322
1323       Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1324
1325       --  Restore settings of saved switches to entry values
1326
1327       Current_Sem_Unit       := S_Sem_Unit;
1328       Full_Analysis          := S_Full_Analysis;
1329       In_Default_Expression  := S_In_Default_Expr;
1330       Inside_A_Generic       := S_Inside_A_Generic;
1331       New_Nodes_OK           := S_New_Nodes_OK;
1332       Outer_Generic_Scope    := S_Outer_Gen_Scope;
1333       GNAT_Mode              := S_GNAT_Mode;
1334
1335       Restore_Opt_Config_Switches (Save_Config_Switches);
1336       Expander_Mode_Restore;
1337
1338    end Semantics;
1339 end Sem;