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-2007, 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 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 Sem_Attr; use Sem_Attr;
  38 with Sem_Ch2;  use Sem_Ch2;
  39 with Sem_Ch3;  use Sem_Ch3;
  40 with Sem_Ch4;  use Sem_Ch4;
  41 with Sem_Ch5;  use Sem_Ch5;
  42 with Sem_Ch6;  use Sem_Ch6;
  43 with Sem_Ch7;  use Sem_Ch7;
  44 with Sem_Ch8;  use Sem_Ch8;
  45 with Sem_Ch9;  use Sem_Ch9;
  46 with Sem_Ch10; use Sem_Ch10;
  47 with Sem_Ch11; use Sem_Ch11;
  48 with Sem_Ch12; use Sem_Ch12;
  49 with Sem_Ch13; use Sem_Ch13;
  50 with Sem_Prag; use Sem_Prag;
  51 with Sem_Util; use Sem_Util;
  52 with Sinfo;    use Sinfo;
  53 with Stand;    use Stand;
  54 with Uintp;    use Uintp;
  55
  56 with Unchecked_Deallocation;
  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_Extended_Return_Statement =>
 190             Analyze_Extended_Return_Statement (N);
 191
 192          when N_Extension_Aggregate =>
 193             Analyze_Aggregate (N);
 194
 195          when N_Formal_Object_Declaration =>
 196             Analyze_Formal_Object_Declaration (N);
 197
 198          when N_Formal_Package_Declaration =>
 199             Analyze_Formal_Package (N);
 200
 201          when N_Formal_Subprogram_Declaration =>
 202             Analyze_Formal_Subprogram (N);
 203
 204          when N_Formal_Type_Declaration =>
 205             Analyze_Formal_Type_Declaration (N);
 206
 207          when N_Free_Statement =>
 208             Analyze_Free_Statement (N);
 209
 210          when N_Freeze_Entity =>
 211             null;  -- no semantic processing required
 212
 213          when N_Full_Type_Declaration =>
 214             Analyze_Type_Declaration (N);
 215
 216          when N_Function_Call =>
 217             Analyze_Function_Call (N);
 218
 219          when N_Function_Instantiation =>
 220             Analyze_Function_Instantiation (N);
 221
 222          when N_Generic_Function_Renaming_Declaration =>
 223             Analyze_Generic_Function_Renaming (N);
 224
 225          when N_Generic_Package_Declaration =>
 226             Analyze_Generic_Package_Declaration (N);
 227
 228          when N_Generic_Package_Renaming_Declaration =>
 229             Analyze_Generic_Package_Renaming (N);
 230
 231          when N_Generic_Procedure_Renaming_Declaration =>
 232             Analyze_Generic_Procedure_Renaming (N);
 233
 234          when N_Generic_Subprogram_Declaration =>
 235             Analyze_Generic_Subprogram_Declaration (N);
 236
 237          when N_Goto_Statement =>
 238             Analyze_Goto_Statement (N);
 239
 240          when N_Handled_Sequence_Of_Statements =>
 241             Analyze_Handled_Statements (N);
 242
 243          when N_Identifier =>
 244             Analyze_Identifier (N);
 245
 246          when N_If_Statement =>
 247             Analyze_If_Statement (N);
 248
 249          when N_Implicit_Label_Declaration =>
 250             Analyze_Implicit_Label_Declaration (N);
 251
 252          when N_In =>
 253             Analyze_Membership_Op (N);
 254
 255          when N_Incomplete_Type_Declaration =>
 256             Analyze_Incomplete_Type_Decl (N);
 257
 258          when N_Indexed_Component =>
 259             Analyze_Indexed_Component_Form (N);
 260
 261          when N_Integer_Literal =>
 262             Analyze_Integer_Literal (N);
 263
 264          when N_Itype_Reference =>
 265             Analyze_Itype_Reference (N);
 266
 267          when N_Label =>
 268             Analyze_Label (N);
 269
 270          when N_Loop_Statement =>
 271             Analyze_Loop_Statement (N);
 272
 273          when N_Not_In =>
 274             Analyze_Membership_Op (N);
 275
 276          when N_Null =>
 277             Analyze_Null (N);
 278
 279          when N_Null_Statement =>
 280             Analyze_Null_Statement (N);
 281
 282          when N_Number_Declaration =>
 283             Analyze_Number_Declaration (N);
 284
 285          when N_Object_Declaration =>
 286             Analyze_Object_Declaration (N);
 287
 288          when N_Object_Renaming_Declaration  =>
 289             Analyze_Object_Renaming (N);
 290
 291          when N_Operator_Symbol =>
 292             Analyze_Operator_Symbol (N);
 293
 294          when N_Op_Abs =>
 295             Analyze_Unary_Op (N);
 296
 297          when N_Op_Add =>
 298             Analyze_Arithmetic_Op (N);
 299
 300          when N_Op_And =>
 301             Analyze_Logical_Op (N);
 302
 303          when N_Op_Concat =>
 304             Analyze_Concatenation (N);
 305
 306          when N_Op_Divide =>
 307             Analyze_Arithmetic_Op (N);
 308
 309          when N_Op_Eq =>
 310             Analyze_Equality_Op (N);
 311
 312          when N_Op_Expon =>
 313             Analyze_Arithmetic_Op (N);
 314
 315          when N_Op_Ge =>
 316             Analyze_Comparison_Op (N);
 317
 318          when N_Op_Gt =>
 319             Analyze_Comparison_Op (N);
 320
 321          when N_Op_Le =>
 322             Analyze_Comparison_Op (N);
 323
 324          when N_Op_Lt =>
 325             Analyze_Comparison_Op (N);
 326
 327          when N_Op_Minus =>
 328             Analyze_Unary_Op (N);
 329
 330          when N_Op_Mod =>
 331             Analyze_Arithmetic_Op (N);
 332
 333          when N_Op_Multiply =>
 334             Analyze_Arithmetic_Op (N);
 335
 336          when N_Op_Ne =>
 337             Analyze_Equality_Op (N);
 338
 339          when N_Op_Not =>
 340             Analyze_Negation (N);
 341
 342          when N_Op_Or =>
 343             Analyze_Logical_Op (N);
 344
 345          when N_Op_Plus =>
 346             Analyze_Unary_Op (N);
 347
 348          when N_Op_Rem =>
 349             Analyze_Arithmetic_Op (N);
 350
 351          when N_Op_Rotate_Left =>
 352             Analyze_Arithmetic_Op (N);
 353
 354          when N_Op_Rotate_Right =>
 355             Analyze_Arithmetic_Op (N);
 356
 357          when N_Op_Shift_Left =>
 358             Analyze_Arithmetic_Op (N);
 359
 360          when N_Op_Shift_Right =>
 361             Analyze_Arithmetic_Op (N);
 362
 363          when N_Op_Shift_Right_Arithmetic =>
 364             Analyze_Arithmetic_Op (N);
 365
 366          when N_Op_Subtract =>
 367             Analyze_Arithmetic_Op (N);
 368
 369          when N_Op_Xor =>
 370             Analyze_Logical_Op (N);
 371
 372          when N_Or_Else =>
 373             Analyze_Short_Circuit (N);
 374
 375          when N_Others_Choice =>
 376             Analyze_Others_Choice (N);
 377
 378          when N_Package_Body =>
 379             Analyze_Package_Body (N);
 380
 381          when N_Package_Body_Stub =>
 382             Analyze_Package_Body_Stub (N);
 383
 384          when N_Package_Declaration =>
 385             Analyze_Package_Declaration (N);
 386
 387          when N_Package_Instantiation =>
 388             Analyze_Package_Instantiation (N);
 389
 390          when N_Package_Renaming_Declaration =>
 391             Analyze_Package_Renaming (N);
 392
 393          when N_Package_Specification =>
 394             Analyze_Package_Specification (N);
 395
 396          when N_Parameter_Association =>
 397             Analyze_Parameter_Association (N);
 398
 399          when N_Pragma =>
 400             Analyze_Pragma (N);
 401
 402          when N_Private_Extension_Declaration =>
 403             Analyze_Private_Extension_Declaration (N);
 404
 405          when N_Private_Type_Declaration =>
 406             Analyze_Private_Type_Declaration (N);
 407
 408          when N_Procedure_Call_Statement =>
 409             Analyze_Procedure_Call (N);
 410
 411          when N_Procedure_Instantiation =>
 412             Analyze_Procedure_Instantiation (N);
 413
 414          when N_Protected_Body =>
 415             Analyze_Protected_Body (N);
 416
 417          when N_Protected_Body_Stub =>
 418             Analyze_Protected_Body_Stub (N);
 419
 420          when N_Protected_Definition =>
 421             Analyze_Protected_Definition (N);
 422
 423          when N_Protected_Type_Declaration =>
 424             Analyze_Protected_Type (N);
 425
 426          when N_Qualified_Expression =>
 427             Analyze_Qualified_Expression (N);
 428
 429          when N_Raise_Statement =>
 430             Analyze_Raise_Statement (N);
 431
 432          when N_Raise_xxx_Error =>
 433             Analyze_Raise_xxx_Error (N);
 434
 435          when N_Range =>
 436             Analyze_Range (N);
 437
 438          when N_Range_Constraint =>
 439             Analyze_Range (Range_Expression (N));
 440
 441          when N_Real_Literal =>
 442             Analyze_Real_Literal (N);
 443
 444          when N_Record_Representation_Clause =>
 445             Analyze_Record_Representation_Clause (N);
 446
 447          when N_Reference =>
 448             Analyze_Reference (N);
 449
 450          when N_Requeue_Statement =>
 451             Analyze_Requeue (N);
 452
 453          when N_Simple_Return_Statement =>
 454             Analyze_Simple_Return_Statement (N);
 455
 456          when N_Selected_Component =>
 457             Find_Selected_Component (N);
 458             --  ??? why not Analyze_Selected_Component, needs comments
 459
 460          when N_Selective_Accept =>
 461             Analyze_Selective_Accept (N);
 462
 463          when N_Single_Protected_Declaration =>
 464             Analyze_Single_Protected (N);
 465
 466          when N_Single_Task_Declaration =>
 467             Analyze_Single_Task (N);
 468
 469          when N_Slice =>
 470             Analyze_Slice (N);
 471
 472          when N_String_Literal =>
 473             Analyze_String_Literal (N);
 474
 475          when N_Subprogram_Body =>
 476             Analyze_Subprogram_Body (N);
 477
 478          when N_Subprogram_Body_Stub =>
 479             Analyze_Subprogram_Body_Stub (N);
 480
 481          when N_Subprogram_Declaration =>
 482             Analyze_Subprogram_Declaration (N);
 483
 484          when N_Subprogram_Info =>
 485             Analyze_Subprogram_Info (N);
 486
 487          when N_Subprogram_Renaming_Declaration =>
 488             Analyze_Subprogram_Renaming (N);
 489
 490          when N_Subtype_Declaration =>
 491             Analyze_Subtype_Declaration (N);
 492
 493          when N_Subtype_Indication =>
 494             Analyze_Subtype_Indication (N);
 495
 496          when N_Subunit =>
 497             Analyze_Subunit (N);
 498
 499          when N_Task_Body =>
 500             Analyze_Task_Body (N);
 501
 502          when N_Task_Body_Stub =>
 503             Analyze_Task_Body_Stub (N);
 504
 505          when N_Task_Definition =>
 506             Analyze_Task_Definition (N);
 507
 508          when N_Task_Type_Declaration =>
 509             Analyze_Task_Type (N);
 510
 511          when N_Terminate_Alternative =>
 512             Analyze_Terminate_Alternative (N);
 513
 514          when N_Timed_Entry_Call =>
 515             Analyze_Timed_Entry_Call (N);
 516
 517          when N_Triggering_Alternative =>
 518             Analyze_Triggering_Alternative (N);
 519
 520          when N_Type_Conversion =>
 521             Analyze_Type_Conversion (N);
 522
 523          when N_Unchecked_Expression =>
 524             Analyze_Unchecked_Expression (N);
 525
 526          when N_Unchecked_Type_Conversion =>
 527             Analyze_Unchecked_Type_Conversion (N);
 528
 529          when N_Use_Package_Clause =>
 530             Analyze_Use_Package (N);
 531
 532          when N_Use_Type_Clause =>
 533             Analyze_Use_Type (N);
 534
 535          when N_Validate_Unchecked_Conversion =>
 536             null;
 537
 538          when N_Variant_Part =>
 539             Analyze_Variant_Part (N);
 540
 541          when N_With_Clause =>
 542             Analyze_With_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          --  Push/Pop nodes normally don't come through an analyze call. An
 561          --  exception is the dummy ones bracketing a subprogram body. In any
 562          --  case there is nothing to be done to analyze such nodes.
 563
 564          when N_Push_Pop_xxx_Label =>
 565             null;
 566
 567          --  For the remaining node types, we generate compiler abort, because
 568          --  these nodes are always analyzed within the Sem_Chn routines and
 569          --  there should never be a case of making a call to the main Analyze
 570          --  routine for these node kinds. For example, an N_Access_Definition
 571          --  node appears only in the context of a type declaration, and is
 572          --  processed by the analyze routine for type declarations.
 573
 574          when
 575            N_Abortable_Part                         |
 576            N_Access_Definition                      |
 577            N_Access_Function_Definition             |
 578            N_Access_Procedure_Definition            |
 579            N_Access_To_Object_Definition            |
 580            N_Case_Statement_Alternative             |
 581            N_Compilation_Unit_Aux                   |
 582            N_Component_Association                  |
 583            N_Component_Clause                       |
 584            N_Component_Definition                   |
 585            N_Component_List                         |
 586            N_Constrained_Array_Definition           |
 587            N_Decimal_Fixed_Point_Definition         |
 588            N_Defining_Character_Literal             |
 589            N_Defining_Identifier                    |
 590            N_Defining_Operator_Symbol               |
 591            N_Defining_Program_Unit_Name             |
 592            N_Delta_Constraint                       |
 593            N_Derived_Type_Definition                |
 594            N_Designator                             |
 595            N_Digits_Constraint                      |
 596            N_Discriminant_Association               |
 597            N_Discriminant_Specification             |
 598            N_Elsif_Part                             |
 599            N_Entry_Call_Statement                   |
 600            N_Enumeration_Type_Definition            |
 601            N_Exception_Handler                      |
 602            N_Floating_Point_Definition              |
 603            N_Formal_Decimal_Fixed_Point_Definition  |
 604            N_Formal_Derived_Type_Definition         |
 605            N_Formal_Discrete_Type_Definition        |
 606            N_Formal_Floating_Point_Definition       |
 607            N_Formal_Modular_Type_Definition         |
 608            N_Formal_Ordinary_Fixed_Point_Definition |
 609            N_Formal_Private_Type_Definition         |
 610            N_Formal_Signed_Integer_Type_Definition  |
 611            N_Function_Specification                 |
 612            N_Generic_Association                    |
 613            N_Index_Or_Discriminant_Constraint       |
 614            N_Iteration_Scheme                       |
 615            N_Loop_Parameter_Specification           |
 616            N_Mod_Clause                             |
 617            N_Modular_Type_Definition                |
 618            N_Ordinary_Fixed_Point_Definition        |
 619            N_Parameter_Specification                |
 620            N_Pragma_Argument_Association            |
 621            N_Procedure_Specification                |
 622            N_Real_Range_Specification               |
 623            N_Record_Definition                      |
 624            N_Signed_Integer_Type_Definition         |
 625            N_Unconstrained_Array_Definition         |
 626            N_Unused_At_Start                        |
 627            N_Unused_At_End                          |
 628            N_Variant                                =>
 629
 630             raise Program_Error;
 631       end case;
 632
 633       Debug_A_Exit ("analyzing  ", N, "  (done)");
 634
 635       --  Now that we have analyzed the node, we call the expander to perform
 636       --  possible expansion. We skip this for subexpressions, because we don't
 637       --  have the type yet, and the expander will need to know the type before
 638       --  it can do its job. For subexpression nodes, the call to the expander
 639       --  happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
 640       --  which can appear in a statement context, and needs expanding now in
 641       --  the case (distinguished by Etype, as documented in Sinfo).
 642
 643       --  The Analyzed flag is also set at this point for non-subexpression
 644       --  nodes (in the case of subexpression nodes, we can't set the flag yet,
 645       --  since resolution and expansion have not yet been completed). Note
 646       --  that for N_Raise_xxx_Error we have to distinguish the expression
 647       --  case from the statement case.
 648
 649       if Nkind (N) not in N_Subexpr
 650         or else (Nkind (N) in N_Raise_xxx_Error
 651                   and then Etype (N) = Standard_Void_Type)
 652       then
 653          Expand (N);
 654       end if;
 655    end Analyze;
 656
 657    --  Version with check(s) suppressed
 658
 659    procedure Analyze (N : Node_Id; Suppress : Check_Id) is
 660    begin
 661       if Suppress = All_Checks then
 662          declare
 663             Svg : constant Suppress_Array := Scope_Suppress;
 664          begin
 665             Scope_Suppress := (others => True);
 666             Analyze (N);
 667             Scope_Suppress := Svg;
 668          end;
 669
 670       else
 671          declare
 672             Svg : constant Boolean := Scope_Suppress (Suppress);
 673          begin
 674             Scope_Suppress (Suppress) := True;
 675             Analyze (N);
 676             Scope_Suppress (Suppress) := Svg;
 677          end;
 678       end if;
 679    end Analyze;
 680
 681    ------------------
 682    -- Analyze_List --
 683    ------------------
 684
 685    procedure Analyze_List (L : List_Id) is
 686       Node : Node_Id;
 687
 688    begin
 689       Node := First (L);
 690       while Present (Node) loop
 691          Analyze (Node);
 692          Next (Node);
 693       end loop;
 694    end Analyze_List;
 695
 696    --  Version with check(s) suppressed
 697
 698    procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
 699    begin
 700       if Suppress = All_Checks then
 701          declare
 702             Svg : constant Suppress_Array := Scope_Suppress;
 703          begin
 704             Scope_Suppress := (others => True);
 705             Analyze_List (L);
 706             Scope_Suppress := Svg;
 707          end;
 708
 709       else
 710          declare
 711             Svg : constant Boolean := Scope_Suppress (Suppress);
 712          begin
 713             Scope_Suppress (Suppress) := True;
 714             Analyze_List (L);
 715             Scope_Suppress (Suppress) := Svg;
 716          end;
 717       end if;
 718    end Analyze_List;
 719
 720    --------------------------
 721    -- Copy_Suppress_Status --
 722    --------------------------
 723
 724    procedure Copy_Suppress_Status
 725      (C    : Check_Id;
 726       From : Entity_Id;
 727       To   : Entity_Id)
 728    is
 729       Found : Boolean;
 730       pragma Warnings (Off, Found);
 731
 732       procedure Search_Stack
 733         (Top   : Suppress_Stack_Entry_Ptr;
 734          Found : out Boolean);
 735       --  Search given suppress stack for matching entry for entity. If found
 736       --  then set Checks_May_Be_Suppressed on To, and push an appropriate
 737       --  entry for To onto the local suppress stack.
 738
 739       ------------------
 740       -- Search_Stack --
 741       ------------------
 742
 743       procedure Search_Stack
 744         (Top   : Suppress_Stack_Entry_Ptr;
 745          Found : out Boolean)
 746       is
 747          Ptr : Suppress_Stack_Entry_Ptr;
 748
 749       begin
 750          Ptr := Top;
 751          while Ptr /= null loop
 752             if Ptr.Entity = From
 753               and then (Ptr.Check = All_Checks or else Ptr.Check = C)
 754             then
 755                if Ptr.Suppress then
 756                   Set_Checks_May_Be_Suppressed (To, True);
 757                   Push_Local_Suppress_Stack_Entry
 758                     (Entity   => To,
 759                      Check    => C,
 760                      Suppress => True);
 761                   Found := True;
 762                   return;
 763                end if;
 764             end if;
 765
 766             Ptr := Ptr.Prev;
 767          end loop;
 768
 769          Found := False;
 770          return;
 771       end Search_Stack;
 772
 773    --  Start of processing for Copy_Suppress_Status
 774
 775    begin
 776       if not Checks_May_Be_Suppressed (From) then
 777          return;
 778       end if;
 779
 780       --  First search the local entity suppress stack, we search this in
 781       --  reverse order so that we get the innermost entry that applies to
 782       --  this case if there are nested entries. Note that for the purpose
 783       --  of this procedure we are ONLY looking for entries corresponding
 784       --  to a two-argument Suppress, where the second argument matches From.
 785
 786       Search_Stack (Global_Suppress_Stack_Top, Found);
 787
 788       if Found then
 789          return;
 790       end if;
 791
 792       --  Now search the global entity suppress table for a matching entry
 793       --  We also search this in reverse order so that if there are multiple
 794       --  pragmas for the same entity, the last one applies.
 795
 796       Search_Stack (Local_Suppress_Stack_Top, Found);
 797    end Copy_Suppress_Status;
 798
 799    -------------------------
 800    -- Enter_Generic_Scope --
 801    -------------------------
 802
 803    procedure Enter_Generic_Scope (S : Entity_Id) is
 804    begin
 805       if No (Outer_Generic_Scope) then
 806          Outer_Generic_Scope := S;
 807       end if;
 808    end Enter_Generic_Scope;
 809
 810    ------------------------
 811    -- Exit_Generic_Scope --
 812    ------------------------
 813
 814    procedure Exit_Generic_Scope  (S : Entity_Id) is
 815    begin
 816       if S = Outer_Generic_Scope then
 817          Outer_Generic_Scope := Empty;
 818       end if;
 819    end Exit_Generic_Scope;
 820
 821    -----------------------
 822    -- Explicit_Suppress --
 823    -----------------------
 824
 825    function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
 826       Ptr : Suppress_Stack_Entry_Ptr;
 827
 828    begin
 829       if not Checks_May_Be_Suppressed (E) then
 830          return False;
 831
 832       else
 833          Ptr := Global_Suppress_Stack_Top;
 834          while Ptr /= null loop
 835             if Ptr.Entity = E
 836               and then (Ptr.Check = All_Checks or else Ptr.Check = C)
 837             then
 838                return Ptr.Suppress;
 839             end if;
 840
 841             Ptr := Ptr.Prev;
 842          end loop;
 843       end if;
 844
 845       return False;
 846    end Explicit_Suppress;
 847
 848    -----------------------------
 849    -- External_Ref_In_Generic --
 850    -----------------------------
 851
 852    function External_Ref_In_Generic (E : Entity_Id) return Boolean is
 853       Scop : Entity_Id;
 854
 855    begin
 856       --  Entity is global if defined outside of current outer_generic_scope:
 857       --  Either the entity has a smaller depth that the outer generic, or it
 858       --  is in a different compilation unit, or it is defined within a unit
 859       --  in the same compilation, that is not within the outer_generic.
 860
 861       if No (Outer_Generic_Scope) then
 862          return False;
 863
 864       elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
 865         or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
 866       then
 867          return True;
 868
 869       else
 870          Scop := Scope (E);
 871
 872          while Present (Scop) loop
 873             if Scop = Outer_Generic_Scope then
 874                return False;
 875             elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
 876                return True;
 877             else
 878                Scop := Scope (Scop);
 879             end if;
 880          end loop;
 881
 882          return True;
 883       end if;
 884    end External_Ref_In_Generic;
 885
 886    ----------------
 887    -- Initialize --
 888    ----------------
 889
 890    procedure Initialize is
 891       Next : Suppress_Stack_Entry_Ptr;
 892
 893       procedure Free is new Unchecked_Deallocation
 894         (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
 895
 896    begin
 897       --  Free any global suppress stack entries from a previous invocation
 898       --  of the compiler (in the normal case this loop does nothing).
 899
 900       while Suppress_Stack_Entries /= null loop
 901          Next := Global_Suppress_Stack_Top.Next;
 902          Free (Suppress_Stack_Entries);
 903          Suppress_Stack_Entries := Next;
 904       end loop;
 905
 906       Local_Suppress_Stack_Top := null;
 907       Global_Suppress_Stack_Top := null;
 908
 909       --  Clear scope stack, and reset global variables
 910
 911       Scope_Stack.Init;
 912       Unloaded_Subunits := False;
 913    end Initialize;
 914
 915    ------------------------------
 916    -- Insert_After_And_Analyze --
 917    ------------------------------
 918
 919    procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
 920       Node : Node_Id;
 921
 922    begin
 923       if Present (M) then
 924
 925          --  If we are not at the end of the list, then the easiest
 926          --  coding is simply to insert before our successor
 927
 928          if Present (Next (N)) then
 929             Insert_Before_And_Analyze (Next (N), M);
 930
 931          --  Case of inserting at the end of the list
 932
 933          else
 934             --  Capture the Node_Id of the node to be inserted. This Node_Id
 935             --  will still be the same after the insert operation.
 936
 937             Node := M;
 938             Insert_After (N, M);
 939
 940             --  Now just analyze from the inserted node to the end of
 941             --  the new list (note that this properly handles the case
 942             --  where any of the analyze calls result in the insertion of
 943             --  nodes after the analyzed node, expecting analysis).
 944
 945             while Present (Node) loop
 946                Analyze (Node);
 947                Mark_Rewrite_Insertion (Node);
 948                Next (Node);
 949             end loop;
 950          end if;
 951       end if;
 952    end Insert_After_And_Analyze;
 953
 954    --  Version with check(s) suppressed
 955
 956    procedure Insert_After_And_Analyze
 957      (N        : Node_Id;
 958       M        : Node_Id;
 959       Suppress : Check_Id)
 960    is
 961    begin
 962       if Suppress = All_Checks then
 963          declare
 964             Svg : constant Suppress_Array := Scope_Suppress;
 965          begin
 966             Scope_Suppress := (others => True);
 967             Insert_After_And_Analyze (N, M);
 968             Scope_Suppress := Svg;
 969          end;
 970
 971       else
 972          declare
 973             Svg : constant Boolean := Scope_Suppress (Suppress);
 974          begin
 975             Scope_Suppress (Suppress) := True;
 976             Insert_After_And_Analyze (N, M);
 977             Scope_Suppress (Suppress) := Svg;
 978          end;
 979       end if;
 980    end Insert_After_And_Analyze;
 981
 982    -------------------------------
 983    -- Insert_Before_And_Analyze --
 984    -------------------------------
 985
 986    procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
 987       Node : Node_Id;
 988
 989    begin
 990       if Present (M) then
 991
 992          --  Capture the Node_Id of the first list node to be inserted.
 993          --  This will still be the first node after the insert operation,
 994          --  since Insert_List_After does not modify the Node_Id values.
 995
 996          Node := M;
 997          Insert_Before (N, M);
 998
 999          --  The insertion does not change the Id's of any of the nodes in
1000          --  the list, and they are still linked, so we can simply loop from
1001          --  the original first node until we meet the node before which the
1002          --  insertion is occurring. Note that this properly handles the case
1003          --  where any of the analyzed nodes insert nodes after themselves,
1004          --  expecting them to get analyzed.
1005
1006          while Node /= N loop
1007             Analyze (Node);
1008             Mark_Rewrite_Insertion (Node);
1009             Next (Node);
1010          end loop;
1011       end if;
1012    end Insert_Before_And_Analyze;
1013
1014    --  Version with check(s) suppressed
1015
1016    procedure Insert_Before_And_Analyze
1017      (N        : Node_Id;
1018       M        : Node_Id;
1019       Suppress : Check_Id)
1020    is
1021    begin
1022       if Suppress = All_Checks then
1023          declare
1024             Svg : constant Suppress_Array := Scope_Suppress;
1025          begin
1026             Scope_Suppress := (others => True);
1027             Insert_Before_And_Analyze (N, M);
1028             Scope_Suppress := Svg;
1029          end;
1030
1031       else
1032          declare
1033             Svg : constant Boolean := Scope_Suppress (Suppress);
1034          begin
1035             Scope_Suppress (Suppress) := True;
1036             Insert_Before_And_Analyze (N, M);
1037             Scope_Suppress (Suppress) := Svg;
1038          end;
1039       end if;
1040    end Insert_Before_And_Analyze;
1041
1042    -----------------------------------
1043    -- Insert_List_After_And_Analyze --
1044    -----------------------------------
1045
1046    procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1047       After : constant Node_Id := Next (N);
1048       Node  : Node_Id;
1049
1050    begin
1051       if Is_Non_Empty_List (L) then
1052
1053          --  Capture the Node_Id of the first list node to be inserted.
1054          --  This will still be the first node after the insert operation,
1055          --  since Insert_List_After does not modify the Node_Id values.
1056
1057          Node := First (L);
1058          Insert_List_After (N, L);
1059
1060          --  Now just analyze from the original first node until we get to
1061          --  the successor of the original insertion point (which may be
1062          --  Empty if the insertion point was at the end of the list). Note
1063          --  that this properly handles the case where any of the analyze
1064          --  calls result in the insertion of nodes after the analyzed
1065          --  node (possibly calling this routine recursively).
1066
1067          while Node /= After loop
1068             Analyze (Node);
1069             Mark_Rewrite_Insertion (Node);
1070             Next (Node);
1071          end loop;
1072       end if;
1073    end Insert_List_After_And_Analyze;
1074
1075    --  Version with check(s) suppressed
1076
1077    procedure Insert_List_After_And_Analyze
1078      (N : Node_Id; L : List_Id; Suppress : Check_Id)
1079    is
1080    begin
1081       if Suppress = All_Checks then
1082          declare
1083             Svg : constant Suppress_Array := Scope_Suppress;
1084          begin
1085             Scope_Suppress := (others => True);
1086             Insert_List_After_And_Analyze (N, L);
1087             Scope_Suppress := Svg;
1088          end;
1089
1090       else
1091          declare
1092             Svg : constant Boolean := Scope_Suppress (Suppress);
1093          begin
1094             Scope_Suppress (Suppress) := True;
1095             Insert_List_After_And_Analyze (N, L);
1096             Scope_Suppress (Suppress) := Svg;
1097          end;
1098       end if;
1099    end Insert_List_After_And_Analyze;
1100
1101    ------------------------------------
1102    -- Insert_List_Before_And_Analyze --
1103    ------------------------------------
1104
1105    procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1106       Node : Node_Id;
1107
1108    begin
1109       if Is_Non_Empty_List (L) then
1110
1111          --  Capture the Node_Id of the first list node to be inserted.
1112          --  This will still be the first node after the insert operation,
1113          --  since Insert_List_After does not modify the Node_Id values.
1114
1115          Node := First (L);
1116          Insert_List_Before (N, L);
1117
1118          --  The insertion does not change the Id's of any of the nodes in
1119          --  the list, and they are still linked, so we can simply loop from
1120          --  the original first node until we meet the node before which the
1121          --  insertion is occurring. Note that this properly handles the case
1122          --  where any of the analyzed nodes insert nodes after themselves,
1123          --  expecting them to get analyzed.
1124
1125          while Node /= N loop
1126             Analyze (Node);
1127             Mark_Rewrite_Insertion (Node);
1128             Next (Node);
1129          end loop;
1130       end if;
1131    end Insert_List_Before_And_Analyze;
1132
1133    --  Version with check(s) suppressed
1134
1135    procedure Insert_List_Before_And_Analyze
1136      (N : Node_Id; L : List_Id; Suppress : Check_Id)
1137    is
1138    begin
1139       if Suppress = All_Checks then
1140          declare
1141             Svg : constant Suppress_Array := Scope_Suppress;
1142          begin
1143             Scope_Suppress := (others => True);
1144             Insert_List_Before_And_Analyze (N, L);
1145             Scope_Suppress := Svg;
1146          end;
1147
1148       else
1149          declare
1150             Svg : constant Boolean := Scope_Suppress (Suppress);
1151          begin
1152             Scope_Suppress (Suppress) := True;
1153             Insert_List_Before_And_Analyze (N, L);
1154             Scope_Suppress (Suppress) := Svg;
1155          end;
1156       end if;
1157    end Insert_List_Before_And_Analyze;
1158
1159    -------------------------
1160    -- Is_Check_Suppressed --
1161    -------------------------
1162
1163    function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1164
1165       Ptr : Suppress_Stack_Entry_Ptr;
1166
1167    begin
1168       --  First search the local entity suppress stack, we search this from the
1169       --  top of the stack down, so that we get the innermost entry that
1170       --  applies to this case if there are nested entries.
1171
1172       Ptr := Local_Suppress_Stack_Top;
1173       while Ptr /= null loop
1174          if (Ptr.Entity = Empty or else Ptr.Entity = E)
1175            and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1176          then
1177             return Ptr.Suppress;
1178          end if;
1179
1180          Ptr := Ptr.Prev;
1181       end loop;
1182
1183       --  Now search the global entity suppress table for a matching entry
1184       --  We also search this from the top down so that if there are multiple
1185       --  pragmas for the same entity, the last one applies (not clear what
1186       --  or whether the RM specifies this handling, but it seems reasonable).
1187
1188       Ptr := Global_Suppress_Stack_Top;
1189       while Ptr /= null loop
1190          if (Ptr.Entity = Empty or else Ptr.Entity = E)
1191            and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1192          then
1193             return Ptr.Suppress;
1194          end if;
1195
1196          Ptr := Ptr.Prev;
1197       end loop;
1198
1199       --  If we did not find a matching entry, then use the normal scope
1200       --  suppress value after all (actually this will be the global setting
1201       --  since it clearly was not overridden at any point). For a predefined
1202       --  check, we test the specific flag. For a user defined check, we check
1203       --  the All_Checks flag.
1204
1205       if C in Predefined_Check_Id then
1206          return Scope_Suppress (C);
1207       else
1208          return Scope_Suppress (All_Checks);
1209       end if;
1210    end Is_Check_Suppressed;
1211
1212    ----------
1213    -- Lock --
1214    ----------
1215
1216    procedure Lock is
1217    begin
1218       Scope_Stack.Locked := True;
1219       Scope_Stack.Release;
1220    end Lock;
1221
1222    --------------------------------------
1223    -- Push_Global_Suppress_Stack_Entry --
1224    --------------------------------------
1225
1226    procedure Push_Global_Suppress_Stack_Entry
1227      (Entity   : Entity_Id;
1228       Check    : Check_Id;
1229       Suppress : Boolean)
1230    is
1231    begin
1232       Global_Suppress_Stack_Top :=
1233         new Suppress_Stack_Entry'
1234           (Entity   => Entity,
1235            Check    => Check,
1236            Suppress => Suppress,
1237            Prev     => Global_Suppress_Stack_Top,
1238            Next     => Suppress_Stack_Entries);
1239       Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1240       return;
1241
1242    end Push_Global_Suppress_Stack_Entry;
1243
1244    -------------------------------------
1245    -- Push_Local_Suppress_Stack_Entry --
1246    -------------------------------------
1247
1248    procedure Push_Local_Suppress_Stack_Entry
1249      (Entity   : Entity_Id;
1250       Check    : Check_Id;
1251       Suppress : Boolean)
1252    is
1253    begin
1254       Local_Suppress_Stack_Top :=
1255         new Suppress_Stack_Entry'
1256           (Entity   => Entity,
1257            Check    => Check,
1258            Suppress => Suppress,
1259            Prev     => Local_Suppress_Stack_Top,
1260            Next     => Suppress_Stack_Entries);
1261       Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1262
1263       return;
1264    end Push_Local_Suppress_Stack_Entry;
1265
1266    ---------------
1267    -- Semantics --
1268    ---------------
1269
1270    procedure Semantics (Comp_Unit : Node_Id) is
1271
1272       --  The following locations save the corresponding global flags and
1273       --  variables so that they can be restored on completion. This is
1274       --  needed so that calls to Rtsfind start with the proper default
1275       --  values for these variables, and also that such calls do not
1276       --  disturb the settings for units being analyzed at a higher level.
1277
1278       S_Full_Analysis    : constant Boolean          := Full_Analysis;
1279       S_In_Default_Expr  : constant Boolean          := In_Default_Expression;
1280       S_Inside_A_Generic : constant Boolean          := Inside_A_Generic;
1281       S_New_Nodes_OK     : constant Int              := New_Nodes_OK;
1282       S_Outer_Gen_Scope  : constant Entity_Id        := Outer_Generic_Scope;
1283       S_Sem_Unit         : constant Unit_Number_Type := Current_Sem_Unit;
1284       S_GNAT_Mode        : constant Boolean          := GNAT_Mode;
1285       S_Discard_Names    : constant Boolean          := Global_Discard_Names;
1286
1287       Generic_Main : constant Boolean :=
1288                        Nkind (Unit (Cunit (Main_Unit)))
1289                          in N_Generic_Declaration;
1290       --  If the main unit is generic, every compiled unit, including its
1291       --  context, is compiled with expansion disabled.
1292
1293       Save_Config_Switches : Config_Switches_Type;
1294       --  Variable used to save values of config switches while we analyze
1295       --  the new unit, to be restored on exit for proper recursive behavior.
1296
1297       procedure Do_Analyze;
1298       --  Procedure to analyze the compilation unit. This is called more
1299       --  than once when the high level optimizer is activated.
1300
1301       ----------------
1302       -- Do_Analyze --
1303       ----------------
1304
1305       procedure Do_Analyze is
1306       begin
1307          Save_Scope_Stack;
1308          Push_Scope (Standard_Standard);
1309          Scope_Suppress := Suppress_Options;
1310          Scope_Stack.Table
1311            (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1312          Scope_Stack.Table
1313            (Scope_Stack.Last).Is_Active_Stack_Base := True;
1314          Outer_Generic_Scope := Empty;
1315
1316          --  Now analyze the top level compilation unit node
1317
1318          Analyze (Comp_Unit);
1319
1320          --  Check for scope mismatch on exit from compilation
1321
1322          pragma Assert (Current_Scope = Standard_Standard
1323                           or else Comp_Unit = Cunit (Main_Unit));
1324
1325          --  Then pop entry for Standard, and pop implicit types
1326
1327          Pop_Scope;
1328          Restore_Scope_Stack;
1329       end Do_Analyze;
1330
1331    --  Start of processing for Semantics
1332
1333    begin
1334       Compiler_State   := Analyzing;
1335       Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1336
1337       --  Compile predefined units with GNAT_Mode set to True, to properly
1338       --  process the categorization stuff. However, do not set set GNAT_Mode
1339       --  to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1340       --  Sequential_IO) as this would prevent pragma System_Extend to be
1341       --  taken into account, for example when Text_IO is renaming DEC.Text_IO.
1342
1343       --  Cleaner might be to do the kludge at the point of excluding the
1344       --  pragma (do not exclude for renamings ???)
1345
1346       GNAT_Mode :=
1347         GNAT_Mode
1348           or else Is_Predefined_File_Name
1349                     (Unit_File_Name (Current_Sem_Unit),
1350                      Renamings_Included => False);
1351
1352       if Generic_Main then
1353          Expander_Mode_Save_And_Set (False);
1354       else
1355          Expander_Mode_Save_And_Set
1356            (Operating_Mode = Generate_Code or Debug_Flag_X);
1357       end if;
1358
1359       Full_Analysis         := True;
1360       Inside_A_Generic      := False;
1361       In_Default_Expression := False;
1362
1363       Set_Comes_From_Source_Default (False);
1364       Save_Opt_Config_Switches (Save_Config_Switches);
1365       Set_Opt_Config_Switches
1366         (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1367          Current_Sem_Unit = Main_Unit);
1368
1369       --  Only do analysis of unit that has not already been analyzed
1370
1371       if not Analyzed (Comp_Unit) then
1372          Initialize_Version (Current_Sem_Unit);
1373          if HLO_Active then
1374             Expander_Mode_Save_And_Set (False);
1375             New_Nodes_OK := 1;
1376             Do_Analyze;
1377             Reset_Analyzed_Flags (Comp_Unit);
1378             Expander_Mode_Restore;
1379             High_Level_Optimize (Comp_Unit);
1380             New_Nodes_OK := 0;
1381          end if;
1382
1383          Do_Analyze;
1384       end if;
1385
1386       --  Save indication of dynamic elaboration checks for ALI file
1387
1388       Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1389
1390       --  Restore settings of saved switches to entry values
1391
1392       Current_Sem_Unit       := S_Sem_Unit;
1393       Full_Analysis          := S_Full_Analysis;
1394       In_Default_Expression  := S_In_Default_Expr;
1395       Inside_A_Generic       := S_Inside_A_Generic;
1396       New_Nodes_OK           := S_New_Nodes_OK;
1397       Outer_Generic_Scope    := S_Outer_Gen_Scope;
1398       GNAT_Mode              := S_GNAT_Mode;
1399       Global_Discard_Names   := S_Discard_Names;
1400
1401       Restore_Opt_Config_Switches (Save_Config_Switches);
1402       Expander_Mode_Restore;
1403
1404    end Semantics;
1405 end Sem;