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