gcc/ada/sem_ch9.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 9                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Errout;   use Errout;
  30 with Exp_Ch9;  use Exp_Ch9;
  31 with Elists;   use Elists;
  32 with Freeze;   use Freeze;
  33 with Lib.Xref; use Lib.Xref;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Restrict; use Restrict;
  39 with Rident;   use Rident;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Aux;  use Sem_Aux;
  43 with Sem_Ch3;  use Sem_Ch3;
  44 with Sem_Ch5;  use Sem_Ch5;
  45 with Sem_Ch6;  use Sem_Ch6;
  46 with Sem_Ch8;  use Sem_Ch8;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Res;  use Sem_Res;
  49 with Sem_Type; use Sem_Type;
  50 with Sem_Util; use Sem_Util;
  51 with Sem_Warn; use Sem_Warn;
  52 with Snames;   use Snames;
  53 with Stand;    use Stand;
  54 with Sinfo;    use Sinfo;
  55 with Style;
  56 with Targparm; use Targparm;
  57 with Tbuild;   use Tbuild;
  58 with Uintp;    use Uintp;
  59
  60 package body Sem_Ch9 is
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
  67    --  Given either a protected definition or a task definition in D, check
  68    --  the corresponding restriction parameter identifier R, and if it is set,
  69    --  count the entries (checking the static requirement), and compare with
  70    --  the given maximum.
  71
  72    procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
  73    --  N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
  74    --  Complete decoration of T and check legality of the covered interfaces.
  75
  76    procedure Check_Triggering_Statement
  77      (Trigger        : Node_Id;
  78       Error_Node     : Node_Id;
  79       Is_Dispatching : out Boolean);
  80    --  Examine the triggering statement of a select statement, conditional or
  81    --  timed entry call. If Trigger is a dispatching call, return its status
  82    --  in Is_Dispatching and check whether the primitive belongs to a limited
  83    --  interface. If it does not, emit an error at Error_Node.
  84
  85    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
  86    --  Find entity in corresponding task or protected declaration. Use full
  87    --  view if first declaration was for an incomplete type.
  88
  89    procedure Install_Declarations (Spec : Entity_Id);
  90    --  Utility to make visible in corresponding body the entities defined in
  91    --  task, protected type declaration, or entry declaration.
  92
  93    -----------------------------
  94    -- Analyze_Abort_Statement --
  95    -----------------------------
  96
  97    procedure Analyze_Abort_Statement (N : Node_Id) is
  98       T_Name : Node_Id;
  99
 100    begin
 101       Tasking_Used := True;
 102       T_Name := First (Names (N));
 103       while Present (T_Name) loop
 104          Analyze (T_Name);
 105
 106          if Is_Task_Type (Etype (T_Name))
 107            or else (Ada_Version >= Ada_05
 108                       and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
 109                       and then Is_Interface (Etype (T_Name))
 110                       and then Is_Task_Interface (Etype (T_Name)))
 111          then
 112             Resolve (T_Name);
 113          else
 114             if Ada_Version >= Ada_05 then
 115                Error_Msg_N ("expect task name or task interface class-wide "
 116                           & "object for ABORT", T_Name);
 117             else
 118                Error_Msg_N ("expect task name for ABORT", T_Name);
 119             end if;
 120
 121             return;
 122          end if;
 123
 124          Next (T_Name);
 125       end loop;
 126
 127       Check_Restriction (No_Abort_Statements, N);
 128       Check_Potentially_Blocking_Operation (N);
 129    end Analyze_Abort_Statement;
 130
 131    --------------------------------
 132    -- Analyze_Accept_Alternative --
 133    --------------------------------
 134
 135    procedure Analyze_Accept_Alternative (N : Node_Id) is
 136    begin
 137       Tasking_Used := True;
 138
 139       if Present (Pragmas_Before (N)) then
 140          Analyze_List (Pragmas_Before (N));
 141       end if;
 142
 143       if Present (Condition (N)) then
 144          Analyze_And_Resolve (Condition (N), Any_Boolean);
 145       end if;
 146
 147       Analyze (Accept_Statement (N));
 148
 149       if Is_Non_Empty_List (Statements (N)) then
 150          Analyze_Statements (Statements (N));
 151       end if;
 152    end Analyze_Accept_Alternative;
 153
 154    ------------------------------
 155    -- Analyze_Accept_Statement --
 156    ------------------------------
 157
 158    procedure Analyze_Accept_Statement (N : Node_Id) is
 159       Nam       : constant Entity_Id := Entry_Direct_Name (N);
 160       Formals   : constant List_Id   := Parameter_Specifications (N);
 161       Index     : constant Node_Id   := Entry_Index (N);
 162       Stats     : constant Node_Id   := Handled_Statement_Sequence (N);
 163       Accept_Id : Entity_Id;
 164       Entry_Nam : Entity_Id;
 165       E         : Entity_Id;
 166       Kind      : Entity_Kind;
 167       Task_Nam  : Entity_Id;
 168
 169    begin
 170       Tasking_Used := True;
 171
 172       --  Entry name is initialized to Any_Id. It should get reset to the
 173       --  matching entry entity. An error is signalled if it is not reset.
 174
 175       Entry_Nam := Any_Id;
 176
 177       for J in reverse 0 .. Scope_Stack.Last loop
 178          Task_Nam := Scope_Stack.Table (J).Entity;
 179          exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
 180          Kind :=  Ekind (Task_Nam);
 181
 182          if Kind /= E_Block and then Kind /= E_Loop
 183            and then not Is_Entry (Task_Nam)
 184          then
 185             Error_Msg_N ("enclosing body of accept must be a task", N);
 186             return;
 187          end if;
 188       end loop;
 189
 190       if Ekind (Etype (Task_Nam)) /= E_Task_Type then
 191          Error_Msg_N ("invalid context for accept statement",  N);
 192          return;
 193       end if;
 194
 195       --  In order to process the parameters, we create a defining
 196       --  identifier that can be used as the name of the scope. The
 197       --  name of the accept statement itself is not a defining identifier,
 198       --  and we cannot use its name directly because the task may have
 199       --  any number of accept statements for the same entry.
 200
 201       if Present (Index) then
 202          Accept_Id := New_Internal_Entity
 203            (E_Entry_Family, Current_Scope, Sloc (N), 'E');
 204       else
 205          Accept_Id := New_Internal_Entity
 206            (E_Entry, Current_Scope, Sloc (N), 'E');
 207       end if;
 208
 209       Set_Etype          (Accept_Id, Standard_Void_Type);
 210       Set_Accept_Address (Accept_Id, New_Elmt_List);
 211
 212       if Present (Formals) then
 213          Push_Scope (Accept_Id);
 214          Process_Formals (Formals, N);
 215          Create_Extra_Formals (Accept_Id);
 216          End_Scope;
 217       end if;
 218
 219       --  We set the default expressions processed flag because we don't need
 220       --  default expression functions. This is really more like body entity
 221       --  than a spec entity anyway.
 222
 223       Set_Default_Expressions_Processed (Accept_Id);
 224
 225       E := First_Entity (Etype (Task_Nam));
 226       while Present (E) loop
 227          if Chars (E) = Chars (Nam)
 228            and then (Ekind (E) = Ekind (Accept_Id))
 229            and then Type_Conformant (Accept_Id, E)
 230          then
 231             Entry_Nam := E;
 232             exit;
 233          end if;
 234
 235          Next_Entity (E);
 236       end loop;
 237
 238       if Entry_Nam = Any_Id then
 239          Error_Msg_N ("no entry declaration matches accept statement",  N);
 240          return;
 241       else
 242          Set_Entity (Nam, Entry_Nam);
 243          Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
 244          Style.Check_Identifier (Nam, Entry_Nam);
 245       end if;
 246
 247       --  Verify that the entry is not hidden by a procedure declared in the
 248       --  current block (pathological but possible).
 249
 250       if Current_Scope /= Task_Nam then
 251          declare
 252             E1 : Entity_Id;
 253
 254          begin
 255             E1 := First_Entity (Current_Scope);
 256             while Present (E1) loop
 257                if Ekind (E1) = E_Procedure
 258                  and then Chars (E1) = Chars (Entry_Nam)
 259                  and then Type_Conformant (E1, Entry_Nam)
 260                then
 261                   Error_Msg_N ("entry name is not visible", N);
 262                end if;
 263
 264                Next_Entity (E1);
 265             end loop;
 266          end;
 267       end if;
 268
 269       Set_Convention (Accept_Id, Convention (Entry_Nam));
 270       Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
 271
 272       for J in reverse 0 .. Scope_Stack.Last loop
 273          exit when Task_Nam = Scope_Stack.Table (J).Entity;
 274
 275          if Entry_Nam = Scope_Stack.Table (J).Entity then
 276             Error_Msg_N ("duplicate accept statement for same entry", N);
 277          end if;
 278
 279       end loop;
 280
 281       declare
 282          P : Node_Id := N;
 283       begin
 284          loop
 285             P := Parent (P);
 286             case Nkind (P) is
 287                when N_Task_Body | N_Compilation_Unit =>
 288                   exit;
 289                when N_Asynchronous_Select =>
 290                   Error_Msg_N ("accept statements are not allowed within" &
 291                                " an asynchronous select inner" &
 292                                " to the enclosing task body", N);
 293                   exit;
 294                when others =>
 295                   null;
 296             end case;
 297          end loop;
 298       end;
 299
 300       if Ekind (E) = E_Entry_Family then
 301          if No (Index) then
 302             Error_Msg_N ("missing entry index in accept for entry family", N);
 303          else
 304             Analyze_And_Resolve (Index, Entry_Index_Type (E));
 305             Apply_Range_Check (Index, Entry_Index_Type (E));
 306          end if;
 307
 308       elsif Present (Index) then
 309          Error_Msg_N ("invalid entry index in accept for simple entry", N);
 310       end if;
 311
 312       --  If label declarations present, analyze them. They are declared in the
 313       --  enclosing task, but their enclosing scope is the entry itself, so
 314       --  that goto's to the label are recognized as local to the accept.
 315
 316       if Present (Declarations (N)) then
 317          declare
 318             Decl : Node_Id;
 319             Id   : Entity_Id;
 320
 321          begin
 322             Decl := First (Declarations (N));
 323             while Present (Decl) loop
 324                Analyze (Decl);
 325
 326                pragma Assert
 327                  (Nkind (Decl) = N_Implicit_Label_Declaration);
 328
 329                Id := Defining_Identifier (Decl);
 330                Set_Enclosing_Scope (Id, Entry_Nam);
 331                Next (Decl);
 332             end loop;
 333          end;
 334       end if;
 335
 336       --  If statements are present, they must be analyzed in the context of
 337       --  the entry, so that references to formals are correctly resolved. We
 338       --  also have to add the declarations that are required by the expansion
 339       --  of the accept statement in this case if expansion active.
 340
 341       --  In the case of a select alternative of a selective accept, the
 342       --  expander references the address declaration even if there is no
 343       --  statement list.
 344
 345       --  We also need to create the renaming declarations for the local
 346       --  variables that will replace references to the formals within the
 347       --  accept statement.
 348
 349       Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
 350
 351       --  Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
 352       --  fields on all entry formals (this loop ignores all other entities).
 353       --  Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
 354       --  well, so that we can post accurate warnings on each accept statement
 355       --  for the same entry.
 356
 357       E := First_Entity (Entry_Nam);
 358       while Present (E) loop
 359          if Is_Formal (E) then
 360             Set_Never_Set_In_Source         (E, True);
 361             Set_Is_True_Constant            (E, False);
 362             Set_Current_Value               (E, Empty);
 363             Set_Referenced                  (E, False);
 364             Set_Referenced_As_LHS           (E, False);
 365             Set_Referenced_As_Out_Parameter (E, False);
 366             Set_Has_Pragma_Unreferenced     (E, False);
 367          end if;
 368
 369          Next_Entity (E);
 370       end loop;
 371
 372       --  Analyze statements if present
 373
 374       if Present (Stats) then
 375          Push_Scope (Entry_Nam);
 376          Install_Declarations (Entry_Nam);
 377
 378          Set_Actual_Subtypes (N, Current_Scope);
 379
 380          Analyze (Stats);
 381          Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
 382          End_Scope;
 383       end if;
 384
 385       --  Some warning checks
 386
 387       Check_Potentially_Blocking_Operation (N);
 388       Check_References (Entry_Nam, N);
 389       Set_Entry_Accepted (Entry_Nam);
 390    end Analyze_Accept_Statement;
 391
 392    ---------------------------------
 393    -- Analyze_Asynchronous_Select --
 394    ---------------------------------
 395
 396    procedure Analyze_Asynchronous_Select (N : Node_Id) is
 397       Is_Disp_Select : Boolean := False;
 398       Trigger        : Node_Id;
 399
 400    begin
 401       Tasking_Used := True;
 402       Check_Restriction (Max_Asynchronous_Select_Nesting, N);
 403       Check_Restriction (No_Select_Statements, N);
 404
 405       if Ada_Version >= Ada_05 then
 406          Trigger := Triggering_Statement (Triggering_Alternative (N));
 407
 408          Analyze (Trigger);
 409
 410          --  Ada 2005 (AI-345): Check for a potential dispatching select
 411
 412          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
 413       end if;
 414
 415       --  Ada 2005 (AI-345): The expansion of the dispatching asynchronous
 416       --  select will have to duplicate the triggering statements. Postpone
 417       --  the analysis of the statements till expansion. Analyze only if the
 418       --  expander is disabled in order to catch any semantic errors.
 419
 420       if Is_Disp_Select then
 421          if not Expander_Active then
 422             Analyze_Statements (Statements (Abortable_Part (N)));
 423             Analyze (Triggering_Alternative (N));
 424          end if;
 425
 426       --  Analyze the statements. We analyze statements in the abortable part,
 427       --  because this is the section that is executed first, and that way our
 428       --  remembering of saved values and checks is accurate.
 429
 430       else
 431          Analyze_Statements (Statements (Abortable_Part (N)));
 432          Analyze (Triggering_Alternative (N));
 433       end if;
 434    end Analyze_Asynchronous_Select;
 435
 436    ------------------------------------
 437    -- Analyze_Conditional_Entry_Call --
 438    ------------------------------------
 439
 440    procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
 441       Trigger        : constant Node_Id :=
 442                          Entry_Call_Statement (Entry_Call_Alternative (N));
 443       Is_Disp_Select : Boolean := False;
 444
 445    begin
 446       Check_Restriction (No_Select_Statements, N);
 447       Tasking_Used := True;
 448
 449       --  Ada 2005 (AI-345): The trigger may be a dispatching call
 450
 451       if Ada_Version >= Ada_05 then
 452          Analyze (Trigger);
 453          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
 454       end if;
 455
 456       if List_Length (Else_Statements (N)) = 1
 457         and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
 458       then
 459          Error_Msg_N
 460            ("suspicious form of conditional entry call?!", N);
 461          Error_Msg_N
 462            ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N);
 463       end if;
 464
 465       --  Postpone the analysis of the statements till expansion. Analyze only
 466       --  if the expander is disabled in order to catch any semantic errors.
 467
 468       if Is_Disp_Select then
 469          if not Expander_Active then
 470             Analyze (Entry_Call_Alternative (N));
 471             Analyze_Statements (Else_Statements (N));
 472          end if;
 473
 474       --  Regular select analysis
 475
 476       else
 477          Analyze (Entry_Call_Alternative (N));
 478          Analyze_Statements (Else_Statements (N));
 479       end if;
 480    end Analyze_Conditional_Entry_Call;
 481
 482    --------------------------------
 483    -- Analyze_Delay_Alternative  --
 484    --------------------------------
 485
 486    procedure Analyze_Delay_Alternative (N : Node_Id) is
 487       Expr : Node_Id;
 488       Typ  : Entity_Id;
 489
 490    begin
 491       Tasking_Used := True;
 492       Check_Restriction (No_Delay, N);
 493
 494       if Present (Pragmas_Before (N)) then
 495          Analyze_List (Pragmas_Before (N));
 496       end if;
 497
 498       if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
 499          Expr := Expression (Delay_Statement (N));
 500
 501          --  Defer full analysis until the statement is expanded, to insure
 502          --  that generated code does not move past the guard. The delay
 503          --  expression is only evaluated if the guard is open.
 504
 505          if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
 506             Preanalyze_And_Resolve (Expr, Standard_Duration);
 507          else
 508             Preanalyze_And_Resolve (Expr);
 509          end if;
 510
 511          Typ := First_Subtype (Etype (Expr));
 512
 513          if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
 514            and then not Is_RTE (Typ, RO_CA_Time)
 515            and then not Is_RTE (Typ, RO_RT_Time)
 516          then
 517             Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
 518          end if;
 519
 520          Check_Restriction (No_Fixed_Point, Expr);
 521
 522       else
 523          Analyze (Delay_Statement (N));
 524       end if;
 525
 526       if Present (Condition (N)) then
 527          Analyze_And_Resolve (Condition (N), Any_Boolean);
 528       end if;
 529
 530       if Is_Non_Empty_List (Statements (N)) then
 531          Analyze_Statements (Statements (N));
 532       end if;
 533    end Analyze_Delay_Alternative;
 534
 535    ----------------------------
 536    -- Analyze_Delay_Relative --
 537    ----------------------------
 538
 539    procedure Analyze_Delay_Relative (N : Node_Id) is
 540       E : constant Node_Id := Expression (N);
 541    begin
 542       Check_Restriction (No_Relative_Delay, N);
 543       Tasking_Used := True;
 544       Check_Restriction (No_Delay, N);
 545       Check_Potentially_Blocking_Operation (N);
 546       Analyze_And_Resolve (E, Standard_Duration);
 547       Check_Restriction (No_Fixed_Point, E);
 548    end Analyze_Delay_Relative;
 549
 550    -------------------------
 551    -- Analyze_Delay_Until --
 552    -------------------------
 553
 554    procedure Analyze_Delay_Until (N : Node_Id) is
 555       E   : constant Node_Id := Expression (N);
 556       Typ : Entity_Id;
 557
 558    begin
 559       Tasking_Used := True;
 560       Check_Restriction (No_Delay, N);
 561       Check_Potentially_Blocking_Operation (N);
 562       Analyze (E);
 563       Typ := First_Subtype (Etype (E));
 564
 565       if not Is_RTE (Typ, RO_CA_Time) and then
 566          not Is_RTE (Typ, RO_RT_Time)
 567       then
 568          Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
 569       end if;
 570    end Analyze_Delay_Until;
 571
 572    ------------------------
 573    -- Analyze_Entry_Body --
 574    ------------------------
 575
 576    procedure Analyze_Entry_Body (N : Node_Id) is
 577       Id         : constant Entity_Id := Defining_Identifier (N);
 578       Decls      : constant List_Id   := Declarations (N);
 579       Stats      : constant Node_Id   := Handled_Statement_Sequence (N);
 580       Formals    : constant Node_Id   := Entry_Body_Formal_Part (N);
 581       P_Type     : constant Entity_Id := Current_Scope;
 582       E          : Entity_Id;
 583       Entry_Name : Entity_Id;
 584
 585    begin
 586       Tasking_Used := True;
 587
 588       --  Entry_Name is initialized to Any_Id. It should get reset to the
 589       --  matching entry entity. An error is signalled if it is not reset
 590
 591       Entry_Name := Any_Id;
 592
 593       Analyze (Formals);
 594
 595       if Present (Entry_Index_Specification (Formals)) then
 596          Set_Ekind (Id, E_Entry_Family);
 597       else
 598          Set_Ekind (Id, E_Entry);
 599       end if;
 600
 601       Set_Scope          (Id, Current_Scope);
 602       Set_Etype          (Id, Standard_Void_Type);
 603       Set_Accept_Address (Id, New_Elmt_List);
 604
 605       E := First_Entity (P_Type);
 606       while Present (E) loop
 607          if Chars (E) = Chars (Id)
 608            and then (Ekind (E) = Ekind (Id))
 609            and then Type_Conformant (Id, E)
 610          then
 611             Entry_Name := E;
 612             Set_Convention (Id, Convention (E));
 613             Set_Corresponding_Body (Parent (Entry_Name), Id);
 614             Check_Fully_Conformant (Id, E, N);
 615
 616             if Ekind (Id) = E_Entry_Family then
 617                if not Fully_Conformant_Discrete_Subtypes (
 618                   Discrete_Subtype_Definition (Parent (E)),
 619                   Discrete_Subtype_Definition
 620                     (Entry_Index_Specification (Formals)))
 621                then
 622                   Error_Msg_N
 623                     ("index not fully conformant with previous declaration",
 624                       Discrete_Subtype_Definition
 625                        (Entry_Index_Specification (Formals)));
 626
 627                else
 628                   --  The elaboration of the entry body does not recompute the
 629                   --  bounds of the index, which may have side effects. Inherit
 630                   --  the bounds from the entry declaration. This is critical
 631                   --  if the entry has a per-object constraint. If a bound is
 632                   --  given by a discriminant, it must be reanalyzed in order
 633                   --  to capture the discriminal of the current entry, rather
 634                   --  than that of the protected type.
 635
 636                   declare
 637                      Index_Spec : constant Node_Id :=
 638                                     Entry_Index_Specification (Formals);
 639
 640                      Def : constant Node_Id :=
 641                              New_Copy_Tree
 642                                (Discrete_Subtype_Definition (Parent (E)));
 643
 644                   begin
 645                      if Nkind
 646                        (Original_Node
 647                          (Discrete_Subtype_Definition (Index_Spec))) = N_Range
 648                      then
 649                         Set_Etype (Def, Empty);
 650                         Set_Analyzed (Def, False);
 651
 652                         --  Keep the original subtree to ensure a properly
 653                         --  formed tree (e.g. for ASIS use).
 654
 655                         Rewrite
 656                           (Discrete_Subtype_Definition (Index_Spec), Def);
 657
 658                         Set_Analyzed (Low_Bound (Def), False);
 659                         Set_Analyzed (High_Bound (Def), False);
 660
 661                         if Denotes_Discriminant (Low_Bound (Def)) then
 662                            Set_Entity (Low_Bound (Def), Empty);
 663                         end if;
 664
 665                         if Denotes_Discriminant (High_Bound (Def)) then
 666                            Set_Entity (High_Bound (Def), Empty);
 667                         end if;
 668
 669                         Analyze (Def);
 670                         Make_Index (Def, Index_Spec);
 671                         Set_Etype
 672                           (Defining_Identifier (Index_Spec), Etype (Def));
 673                      end if;
 674                   end;
 675                end if;
 676             end if;
 677
 678             exit;
 679          end if;
 680
 681          Next_Entity (E);
 682       end loop;
 683
 684       if Entry_Name = Any_Id then
 685          Error_Msg_N ("no entry declaration matches entry body",  N);
 686          return;
 687
 688       elsif Has_Completion (Entry_Name) then
 689          Error_Msg_N ("duplicate entry body", N);
 690          return;
 691
 692       else
 693          Set_Has_Completion (Entry_Name);
 694          Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
 695          Style.Check_Identifier (Id, Entry_Name);
 696       end if;
 697
 698       Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
 699       Push_Scope (Entry_Name);
 700
 701       Install_Declarations (Entry_Name);
 702       Set_Actual_Subtypes (N, Current_Scope);
 703
 704       --  The entity for the protected subprogram corresponding to the entry
 705       --  has been created. We retain the name of this entity in the entry
 706       --  body, for use when the corresponding subprogram body is created.
 707       --  Note that entry bodies have no corresponding_spec, and there is no
 708       --  easy link back in the tree between the entry body and the entity for
 709       --  the entry itself, which is why we must propagate some attributes
 710       --  explicitly from spec to body.
 711
 712       Set_Protected_Body_Subprogram
 713         (Id, Protected_Body_Subprogram (Entry_Name));
 714
 715       Set_Entry_Parameters_Type
 716         (Id, Entry_Parameters_Type (Entry_Name));
 717
 718       --  Add a declaration for the Protection object, renaming declarations
 719       --  for the discriminals and privals and finally a declaration for the
 720       --  entry family index (if applicable).
 721
 722       if Expander_Active
 723         and then Is_Protected_Type (P_Type)
 724       then
 725          Install_Private_Data_Declarations
 726            (Sloc (N), Entry_Name, P_Type, N, Decls);
 727       end if;
 728
 729       if Present (Decls) then
 730          Analyze_Declarations (Decls);
 731          Inspect_Deferred_Constant_Completion (Decls);
 732       end if;
 733
 734       if Present (Stats) then
 735          Analyze (Stats);
 736       end if;
 737
 738       --  Check for unreferenced variables etc. Before the Check_References
 739       --  call, we transfer Never_Set_In_Source and Referenced flags from
 740       --  parameters in the spec to the corresponding entities in the body,
 741       --  since we want the warnings on the body entities. Note that we do
 742       --  not have to transfer Referenced_As_LHS, since that flag can only
 743       --  be set for simple variables.
 744
 745       --  At the same time, we set the flags on the spec entities to suppress
 746       --  any warnings on the spec formals, since we also scan the spec.
 747       --  Finally, we propagate the Entry_Component attribute to the body
 748       --  formals, for use in the renaming declarations created later for the
 749       --  formals (see exp_ch9.Add_Formal_Renamings).
 750
 751       declare
 752          E1 : Entity_Id;
 753          E2 : Entity_Id;
 754
 755       begin
 756          E1 := First_Entity (Entry_Name);
 757          while Present (E1) loop
 758             E2 := First_Entity (Id);
 759             while Present (E2) loop
 760                exit when Chars (E1) = Chars (E2);
 761                Next_Entity (E2);
 762             end loop;
 763
 764             --  If no matching body entity, then we already had a detected
 765             --  error of some kind, so just don't worry about these warnings.
 766
 767             if No (E2) then
 768                goto Continue;
 769             end if;
 770
 771             if Ekind (E1) = E_Out_Parameter then
 772                Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
 773                Set_Never_Set_In_Source (E1, False);
 774             end if;
 775
 776             Set_Referenced (E2, Referenced (E1));
 777             Set_Referenced (E1);
 778             Set_Entry_Component (E2, Entry_Component (E1));
 779
 780          <<Continue>>
 781             Next_Entity (E1);
 782          end loop;
 783
 784          Check_References (Id);
 785       end;
 786
 787       --  We still need to check references for the spec, since objects
 788       --  declared in the body are chained (in the First_Entity sense) to
 789       --  the spec rather than the body in the case of entries.
 790
 791       Check_References (Entry_Name);
 792
 793       --  Process the end label, and terminate the scope
 794
 795       Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
 796       End_Scope;
 797
 798       --  If this is an entry family, remove the loop created to provide
 799       --  a scope for the entry index.
 800
 801       if Ekind (Id) = E_Entry_Family
 802         and then Present (Entry_Index_Specification (Formals))
 803       then
 804          End_Scope;
 805       end if;
 806    end Analyze_Entry_Body;
 807
 808    ------------------------------------
 809    -- Analyze_Entry_Body_Formal_Part --
 810    ------------------------------------
 811
 812    procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
 813       Id      : constant Entity_Id := Defining_Identifier (Parent (N));
 814       Index   : constant Node_Id   := Entry_Index_Specification (N);
 815       Formals : constant List_Id   := Parameter_Specifications (N);
 816
 817    begin
 818       Tasking_Used := True;
 819
 820       if Present (Index) then
 821          Analyze (Index);
 822
 823          --  The entry index functions like a loop variable, thus it is known
 824          --  to have a valid value.
 825
 826          Set_Is_Known_Valid (Defining_Identifier (Index));
 827       end if;
 828
 829       if Present (Formals) then
 830          Set_Scope (Id, Current_Scope);
 831          Push_Scope (Id);
 832          Process_Formals (Formals, Parent (N));
 833          End_Scope;
 834       end if;
 835    end Analyze_Entry_Body_Formal_Part;
 836
 837    ------------------------------------
 838    -- Analyze_Entry_Call_Alternative --
 839    ------------------------------------
 840
 841    procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
 842       Call : constant Node_Id := Entry_Call_Statement (N);
 843
 844    begin
 845       Tasking_Used := True;
 846
 847       if Present (Pragmas_Before (N)) then
 848          Analyze_List (Pragmas_Before (N));
 849       end if;
 850
 851       if Nkind (Call) = N_Attribute_Reference then
 852
 853          --  Possibly a stream attribute, but definitely illegal. Other
 854          --  illegalities, such as procedure calls, are diagnosed after
 855          --  resolution.
 856
 857          Error_Msg_N ("entry call alternative requires an entry call", Call);
 858          return;
 859       end if;
 860
 861       Analyze (Call);
 862
 863       if Is_Non_Empty_List (Statements (N)) then
 864          Analyze_Statements (Statements (N));
 865       end if;
 866    end Analyze_Entry_Call_Alternative;
 867
 868    -------------------------------
 869    -- Analyze_Entry_Declaration --
 870    -------------------------------
 871
 872    procedure Analyze_Entry_Declaration (N : Node_Id) is
 873       D_Sdef  : constant Node_Id   := Discrete_Subtype_Definition (N);
 874       Def_Id  : constant Entity_Id := Defining_Identifier (N);
 875       Formals : constant List_Id   := Parameter_Specifications (N);
 876
 877    begin
 878       Generate_Definition (Def_Id);
 879       Tasking_Used := True;
 880
 881       if No (D_Sdef) then
 882          Set_Ekind (Def_Id, E_Entry);
 883       else
 884          Enter_Name (Def_Id);
 885          Set_Ekind (Def_Id, E_Entry_Family);
 886          Analyze (D_Sdef);
 887          Make_Index (D_Sdef, N, Def_Id);
 888       end if;
 889
 890       Set_Etype          (Def_Id, Standard_Void_Type);
 891       Set_Convention     (Def_Id, Convention_Entry);
 892       Set_Accept_Address (Def_Id, New_Elmt_List);
 893
 894       if Present (Formals) then
 895          Set_Scope (Def_Id, Current_Scope);
 896          Push_Scope (Def_Id);
 897          Process_Formals (Formals, N);
 898          Create_Extra_Formals (Def_Id);
 899          End_Scope;
 900       end if;
 901
 902       if Ekind (Def_Id) = E_Entry then
 903          New_Overloaded_Entity (Def_Id);
 904       end if;
 905
 906       Generate_Reference_To_Formals (Def_Id);
 907    end Analyze_Entry_Declaration;
 908
 909    ---------------------------------------
 910    -- Analyze_Entry_Index_Specification --
 911    ---------------------------------------
 912
 913    --  The Defining_Identifier of the entry index specification is local to the
 914    --  entry body, but it must be available in the entry barrier which is
 915    --  evaluated outside of the entry body. The index is eventually renamed as
 916    --  a run-time object, so is visibility is strictly a front-end concern. In
 917    --  order to make it available to the barrier, we create an additional
 918    --  scope, as for a loop, whose only declaration is the index name. This
 919    --  loop is not attached to the tree and does not appear as an entity local
 920    --  to the protected type, so its existence need only be known to routines
 921    --  that process entry families.
 922
 923    procedure Analyze_Entry_Index_Specification (N : Node_Id) is
 924       Iden    : constant Node_Id   := Defining_Identifier (N);
 925       Def     : constant Node_Id   := Discrete_Subtype_Definition (N);
 926       Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
 927
 928    begin
 929       Tasking_Used := True;
 930       Analyze (Def);
 931
 932       --  There is no elaboration of the entry index specification. Therefore,
 933       --  if the index is a range, it is not resolved and expanded, but the
 934       --  bounds are inherited from the entry declaration, and reanalyzed.
 935       --  See Analyze_Entry_Body.
 936
 937       if Nkind (Def) /= N_Range then
 938          Make_Index (Def, N);
 939       end if;
 940
 941       Set_Ekind (Loop_Id, E_Loop);
 942       Set_Scope (Loop_Id, Current_Scope);
 943       Push_Scope (Loop_Id);
 944       Enter_Name (Iden);
 945       Set_Ekind (Iden, E_Entry_Index_Parameter);
 946       Set_Etype (Iden, Etype (Def));
 947    end Analyze_Entry_Index_Specification;
 948
 949    ----------------------------
 950    -- Analyze_Protected_Body --
 951    ----------------------------
 952
 953    procedure Analyze_Protected_Body (N : Node_Id) is
 954       Body_Id : constant Entity_Id := Defining_Identifier (N);
 955       Last_E  : Entity_Id;
 956
 957       Spec_Id : Entity_Id;
 958       --  This is initially the entity of the protected object or protected
 959       --  type involved, but is replaced by the protected type always in the
 960       --  case of a single protected declaration, since this is the proper
 961       --  scope to be used.
 962
 963       Ref_Id : Entity_Id;
 964       --  This is the entity of the protected object or protected type
 965       --  involved, and is the entity used for cross-reference purposes (it
 966       --  differs from Spec_Id in the case of a single protected object, since
 967       --  Spec_Id is set to the protected type in this case).
 968
 969    begin
 970       Tasking_Used := True;
 971       Set_Ekind (Body_Id, E_Protected_Body);
 972       Spec_Id := Find_Concurrent_Spec (Body_Id);
 973
 974       if Present (Spec_Id)
 975         and then Ekind (Spec_Id) = E_Protected_Type
 976       then
 977          null;
 978
 979       elsif Present (Spec_Id)
 980         and then Ekind (Etype (Spec_Id)) = E_Protected_Type
 981         and then not Comes_From_Source (Etype (Spec_Id))
 982       then
 983          null;
 984
 985       else
 986          Error_Msg_N ("missing specification for protected body", Body_Id);
 987          return;
 988       end if;
 989
 990       Ref_Id := Spec_Id;
 991       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
 992       Style.Check_Identifier (Body_Id, Spec_Id);
 993
 994       --  The declarations are always attached to the type
 995
 996       if Ekind (Spec_Id) /= E_Protected_Type then
 997          Spec_Id := Etype (Spec_Id);
 998       end if;
 999
1000       Push_Scope (Spec_Id);
1001       Set_Corresponding_Spec (N, Spec_Id);
1002       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1003       Set_Has_Completion (Spec_Id);
1004       Install_Declarations (Spec_Id);
1005
1006       Expand_Protected_Body_Declarations (N, Spec_Id);
1007
1008       Last_E := Last_Entity (Spec_Id);
1009
1010       Analyze_Declarations (Declarations (N));
1011
1012       --  For visibility purposes, all entities in the body are private. Set
1013       --  First_Private_Entity accordingly, if there was no private part in the
1014       --  protected declaration.
1015
1016       if No (First_Private_Entity (Spec_Id)) then
1017          if Present (Last_E) then
1018             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1019          else
1020             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1021          end if;
1022       end if;
1023
1024       Check_Completion (Body_Id);
1025       Check_References (Spec_Id);
1026       Process_End_Label (N, 't', Ref_Id);
1027       End_Scope;
1028    end Analyze_Protected_Body;
1029
1030    ----------------------------------
1031    -- Analyze_Protected_Definition --
1032    ----------------------------------
1033
1034    procedure Analyze_Protected_Definition (N : Node_Id) is
1035       E : Entity_Id;
1036       L : Entity_Id;
1037
1038       procedure Undelay_Itypes (T : Entity_Id);
1039       --  Itypes created for the private components of a protected type
1040       --  do not receive freeze nodes, because there is no scope in which
1041       --  they can be elaborated, and they can depend on discriminants of
1042       --  the enclosed protected type. Given that the components can be
1043       --  composite types with inner components, we traverse recursively
1044       --  the private components of the protected type, and indicate that
1045       --  all itypes within are frozen. This ensures that no freeze nodes
1046       --  will be generated for them.
1047       --
1048       --  On the other hand, components of the corresponding record are
1049       --  frozen (or receive itype references) as for other records.
1050
1051       --------------------
1052       -- Undelay_Itypes --
1053       --------------------
1054
1055       procedure Undelay_Itypes (T : Entity_Id) is
1056          Comp : Entity_Id;
1057
1058       begin
1059          if Is_Protected_Type (T) then
1060             Comp := First_Private_Entity (T);
1061          elsif Is_Record_Type (T) then
1062             Comp := First_Entity (T);
1063          else
1064             return;
1065          end if;
1066
1067          while Present (Comp) loop
1068             if Is_Type (Comp)
1069               and then Is_Itype (Comp)
1070             then
1071                Set_Has_Delayed_Freeze (Comp, False);
1072                Set_Is_Frozen (Comp);
1073
1074                if Is_Record_Type (Comp)
1075                  or else Is_Protected_Type (Comp)
1076                then
1077                   Undelay_Itypes (Comp);
1078                end if;
1079             end if;
1080
1081             Next_Entity (Comp);
1082          end loop;
1083       end Undelay_Itypes;
1084
1085    --  Start of processing for Analyze_Protected_Definition
1086
1087    begin
1088       Tasking_Used := True;
1089       Analyze_Declarations (Visible_Declarations (N));
1090
1091       if Present (Private_Declarations (N))
1092         and then not Is_Empty_List (Private_Declarations (N))
1093       then
1094          L := Last_Entity (Current_Scope);
1095          Analyze_Declarations (Private_Declarations (N));
1096
1097          if Present (L) then
1098             Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1099          else
1100             Set_First_Private_Entity (Current_Scope,
1101               First_Entity (Current_Scope));
1102          end if;
1103       end if;
1104
1105       E := First_Entity (Current_Scope);
1106       while Present (E) loop
1107          if Ekind_In (E, E_Function, E_Procedure) then
1108             Set_Convention (E, Convention_Protected);
1109
1110          elsif Is_Task_Type (Etype (E))
1111            or else Has_Task (Etype (E))
1112          then
1113             Set_Has_Task (Current_Scope);
1114          end if;
1115
1116          Next_Entity (E);
1117       end loop;
1118
1119       Undelay_Itypes (Current_Scope);
1120
1121       Check_Max_Entries (N, Max_Protected_Entries);
1122       Process_End_Label (N, 'e', Current_Scope);
1123    end Analyze_Protected_Definition;
1124
1125    ----------------------------
1126    -- Analyze_Protected_Type --
1127    ----------------------------
1128
1129    procedure Analyze_Protected_Type (N : Node_Id) is
1130       Def_Id : constant Entity_Id := Defining_Identifier (N);
1131       E      : Entity_Id;
1132       T      : Entity_Id;
1133
1134    begin
1135       if No_Run_Time_Mode then
1136          Error_Msg_CRT ("protected type", N);
1137          return;
1138       end if;
1139
1140       Tasking_Used := True;
1141       Check_Restriction (No_Protected_Types, N);
1142
1143       T := Find_Type_Name (N);
1144
1145       --  In the case of an incomplete type, use the full view, unless it's not
1146       --  present (as can occur for an incomplete view from a limited with).
1147
1148       if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1149          T := Full_View (T);
1150          Set_Completion_Referenced (T);
1151       end if;
1152
1153       Set_Ekind              (T, E_Protected_Type);
1154       Set_Is_First_Subtype   (T, True);
1155       Init_Size_Align        (T);
1156       Set_Etype              (T, T);
1157       Set_Has_Delayed_Freeze (T, True);
1158       Set_Stored_Constraint  (T, No_Elist);
1159       Push_Scope (T);
1160
1161       if Ada_Version >= Ada_05 then
1162          Check_Interfaces (N, T);
1163       end if;
1164
1165       if Present (Discriminant_Specifications (N)) then
1166          if Has_Discriminants (T) then
1167
1168             --  Install discriminants. Also, verify conformance of
1169             --  discriminants of previous and current view. ???
1170
1171             Install_Declarations (T);
1172          else
1173             Process_Discriminants (N);
1174          end if;
1175       end if;
1176
1177       Set_Is_Constrained (T, not Has_Discriminants (T));
1178
1179       Analyze (Protected_Definition (N));
1180
1181       --  In the case where the protected type is declared at a nested level
1182       --  and the No_Local_Protected_Objects restriction applies, issue a
1183       --  warning that objects of the type will violate the restriction.
1184
1185       if not Is_Library_Level_Entity (T)
1186         and then Comes_From_Source (T)
1187         and then Restrictions.Set (No_Local_Protected_Objects)
1188       then
1189          Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
1190
1191          if Error_Msg_Sloc = No_Location then
1192             Error_Msg_N
1193               ("objects of this type will violate " &
1194                "`No_Local_Protected_Objects`?", N);
1195          else
1196             Error_Msg_N
1197               ("objects of this type will violate " &
1198                "`No_Local_Protected_Objects`?#", N);
1199          end if;
1200       end if;
1201
1202       --  Protected types with entries are controlled (because of the
1203       --  Protection component if nothing else), same for any protected type
1204       --  with interrupt handlers. Note that we need to analyze the protected
1205       --  definition to set Has_Entries and such.
1206
1207       if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1208            or else Number_Entries (T) > 1)
1209         and then
1210           (Has_Entries (T)
1211             or else Has_Interrupt_Handler (T)
1212             or else Has_Attach_Handler (T))
1213       then
1214          Set_Has_Controlled_Component (T, True);
1215       end if;
1216
1217       --  The Ekind of components is E_Void during analysis to detect illegal
1218       --  uses. Now it can be set correctly.
1219
1220       E := First_Entity (Current_Scope);
1221       while Present (E) loop
1222          if Ekind (E) = E_Void then
1223             Set_Ekind (E, E_Component);
1224             Init_Component_Location (E);
1225          end if;
1226
1227          Next_Entity (E);
1228       end loop;
1229
1230       End_Scope;
1231
1232       --  Case of a completion of a private declaration
1233
1234       if T /= Def_Id
1235         and then Is_Private_Type (Def_Id)
1236       then
1237          --  Deal with preelaborable initialization. Note that this processing
1238          --  is done by Process_Full_View, but as can be seen below, in this
1239          --  case the call to Process_Full_View is skipped if any serious
1240          --  errors have occurred, and we don't want to lose this check.
1241
1242          if Known_To_Have_Preelab_Init (Def_Id) then
1243             Set_Must_Have_Preelab_Init (T);
1244          end if;
1245
1246          --  Create corresponding record now, because some private dependents
1247          --  may be subtypes of the partial view. Skip if errors are present,
1248          --  to prevent cascaded messages.
1249
1250          if Serious_Errors_Detected = 0
1251            and then Expander_Active
1252          then
1253             Expand_N_Protected_Type_Declaration (N);
1254             Process_Full_View (N, T, Def_Id);
1255          end if;
1256       end if;
1257    end Analyze_Protected_Type;
1258
1259    ---------------------
1260    -- Analyze_Requeue --
1261    ---------------------
1262
1263    procedure Analyze_Requeue (N : Node_Id) is
1264       Count       : Natural := 0;
1265       Entry_Name  : Node_Id := Name (N);
1266       Entry_Id    : Entity_Id;
1267       I           : Interp_Index;
1268       Is_Disp_Req : Boolean;
1269       It          : Interp;
1270       Enclosing   : Entity_Id;
1271       Target_Obj  : Node_Id := Empty;
1272       Req_Scope   : Entity_Id;
1273       Outer_Ent   : Entity_Id;
1274
1275    begin
1276       Check_Restriction (No_Requeue_Statements, N);
1277       Check_Unreachable_Code (N);
1278       Tasking_Used := True;
1279
1280       Enclosing := Empty;
1281       for J in reverse 0 .. Scope_Stack.Last loop
1282          Enclosing := Scope_Stack.Table (J).Entity;
1283          exit when Is_Entry (Enclosing);
1284
1285          if not Ekind_In (Enclosing, E_Block, E_Loop) then
1286             Error_Msg_N ("requeue must appear within accept or entry body", N);
1287             return;
1288          end if;
1289       end loop;
1290
1291       Analyze (Entry_Name);
1292
1293       if Etype (Entry_Name) = Any_Type then
1294          return;
1295       end if;
1296
1297       if Nkind (Entry_Name) = N_Selected_Component then
1298          Target_Obj := Prefix (Entry_Name);
1299          Entry_Name := Selector_Name (Entry_Name);
1300       end if;
1301
1302       --  If an explicit target object is given then we have to check the
1303       --  restrictions of 9.5.4(6).
1304
1305       if Present (Target_Obj) then
1306
1307          --  Locate containing concurrent unit and determine enclosing entry
1308          --  body or outermost enclosing accept statement within the unit.
1309
1310          Outer_Ent := Empty;
1311          for S in reverse 0 .. Scope_Stack.Last loop
1312             Req_Scope := Scope_Stack.Table (S).Entity;
1313
1314             exit when Ekind (Req_Scope) in Task_Kind
1315               or else Ekind (Req_Scope) in Protected_Kind;
1316
1317             if Is_Entry (Req_Scope) then
1318                Outer_Ent := Req_Scope;
1319             end if;
1320          end loop;
1321
1322          pragma Assert (Present (Outer_Ent));
1323
1324          --  Check that the accessibility level of the target object is not
1325          --  greater or equal to the outermost enclosing accept statement (or
1326          --  entry body) unless it is a parameter of the innermost enclosing
1327          --  accept statement (or entry body).
1328
1329          if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1330            and then
1331              (not Is_Entity_Name (Target_Obj)
1332                or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1333                or else Enclosing /= Scope (Entity (Target_Obj)))
1334          then
1335             Error_Msg_N
1336               ("target object has invalid level for requeue", Target_Obj);
1337          end if;
1338       end if;
1339
1340       --  Overloaded case, find right interpretation
1341
1342       if Is_Overloaded (Entry_Name) then
1343          Entry_Id := Empty;
1344
1345          --  Loop over candidate interpretations and filter out any that are
1346          --  not parameterless, are not type conformant, are not entries, or
1347          --  do not come from source.
1348
1349          Get_First_Interp (Entry_Name, I, It);
1350          while Present (It.Nam) loop
1351
1352             --  Note: we test type conformance here, not subtype conformance.
1353             --  Subtype conformance will be tested later on, but it is better
1354             --  for error output in some cases not to do that here.
1355
1356             if (No (First_Formal (It.Nam))
1357                  or else (Type_Conformant (Enclosing, It.Nam)))
1358               and then Ekind (It.Nam) = E_Entry
1359             then
1360                --  Ada 2005 (AI-345): Since protected and task types have
1361                --  primitive entry wrappers, we only consider source entries.
1362
1363                if Comes_From_Source (It.Nam) then
1364                   Count := Count + 1;
1365                   Entry_Id := It.Nam;
1366                else
1367                   Remove_Interp (I);
1368                end if;
1369             end if;
1370
1371             Get_Next_Interp (I, It);
1372          end loop;
1373
1374          if Count = 0 then
1375             Error_Msg_N ("no entry matches context", N);
1376             return;
1377
1378          elsif Count > 1 then
1379             Error_Msg_N ("ambiguous entry name in requeue", N);
1380             return;
1381
1382          else
1383             Set_Is_Overloaded (Entry_Name, False);
1384             Set_Entity (Entry_Name, Entry_Id);
1385          end if;
1386
1387       --  Non-overloaded cases
1388
1389       --  For the case of a reference to an element of an entry family, the
1390       --  Entry_Name is an indexed component.
1391
1392       elsif Nkind (Entry_Name) = N_Indexed_Component then
1393
1394          --  Requeue to an entry out of the body
1395
1396          if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1397             Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1398
1399          --  Requeue from within the body itself
1400
1401          elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1402             Entry_Id := Entity (Prefix (Entry_Name));
1403
1404          else
1405             Error_Msg_N ("invalid entry_name specified",  N);
1406             return;
1407          end if;
1408
1409       --  If we had a requeue of the form REQUEUE A (B), then the parser
1410       --  accepted it (because it could have been a requeue on an entry index.
1411       --  If A turns out not to be an entry family, then the analysis of A (B)
1412       --  turned it into a function call.
1413
1414       elsif Nkind (Entry_Name) = N_Function_Call then
1415          Error_Msg_N
1416            ("arguments not allowed in requeue statement",
1417             First (Parameter_Associations (Entry_Name)));
1418          return;
1419
1420       --  Normal case of no entry family, no argument
1421
1422       else
1423          Entry_Id := Entity (Entry_Name);
1424       end if;
1425
1426       --  Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
1427       --  target type must be a concurrent interface class-wide type and the
1428       --  entry name must be a procedure, flagged by pragma Implemented_By_
1429       --  Entry.
1430
1431       Is_Disp_Req :=
1432         Ada_Version >= Ada_05
1433           and then Present (Target_Obj)
1434           and then Is_Class_Wide_Type (Etype (Target_Obj))
1435           and then Is_Concurrent_Interface (Etype (Target_Obj))
1436           and then Ekind (Entry_Id) = E_Procedure
1437           and then Implemented_By_Entry (Entry_Id);
1438
1439       --  Resolve entry, and check that it is subtype conformant with the
1440       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
1441       --  Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1442
1443       if not Is_Entry (Entry_Id)
1444         and then not Is_Disp_Req
1445       then
1446          Error_Msg_N ("expect entry name in requeue statement", Name (N));
1447
1448       elsif Ekind (Entry_Id) = E_Entry_Family
1449         and then Nkind (Entry_Name) /= N_Indexed_Component
1450       then
1451          Error_Msg_N ("missing index for entry family component", Name (N));
1452
1453       else
1454          Resolve_Entry (Name (N));
1455          Generate_Reference (Entry_Id, Entry_Name);
1456
1457          if Present (First_Formal (Entry_Id)) then
1458             if VM_Target = JVM_Target then
1459                Error_Msg_N
1460                  ("arguments unsupported in requeue statement",
1461                   First_Formal (Entry_Id));
1462                return;
1463             end if;
1464
1465             --  Ada 2005 (AI05-0030): Perform type conformance after skipping
1466             --  the first parameter of Entry_Id since it is the interface
1467             --  controlling formal.
1468
1469             if Is_Disp_Req then
1470                declare
1471                   Enclosing_Formal : Entity_Id;
1472                   Target_Formal    : Entity_Id;
1473
1474                begin
1475                   Enclosing_Formal := First_Formal (Enclosing);
1476                   Target_Formal := Next_Formal (First_Formal (Entry_Id));
1477                   while Present (Enclosing_Formal)
1478                     and then Present (Target_Formal)
1479                   loop
1480                      if not Conforming_Types
1481                               (T1    => Etype (Enclosing_Formal),
1482                                T2    => Etype (Target_Formal),
1483                                Ctype => Subtype_Conformant)
1484                      then
1485                         Error_Msg_Node_2 := Target_Formal;
1486                         Error_Msg_NE
1487                           ("formal & is not subtype conformant with &" &
1488                            "in dispatching requeue", N, Enclosing_Formal);
1489                      end if;
1490
1491                      Next_Formal (Enclosing_Formal);
1492                      Next_Formal (Target_Formal);
1493                   end loop;
1494                end;
1495             else
1496                Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1497             end if;
1498
1499             --  Processing for parameters accessed by the requeue
1500
1501             declare
1502                Ent : Entity_Id;
1503
1504             begin
1505                Ent := First_Formal (Enclosing);
1506                while Present (Ent) loop
1507
1508                   --  For OUT or IN OUT parameter, the effect of the requeue is
1509                   --  to assign the parameter a value on exit from the requeued
1510                   --  body, so we can set it as source assigned. We also clear
1511                   --  the Is_True_Constant indication. We do not need to clear
1512                   --  Current_Value, since the effect of the requeue is to
1513                   --  perform an unconditional goto so that any further
1514                   --  references will not occur anyway.
1515
1516                   if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
1517                      Set_Never_Set_In_Source (Ent, False);
1518                      Set_Is_True_Constant    (Ent, False);
1519                   end if;
1520
1521                   --  For all parameters, the requeue acts as a reference,
1522                   --  since the value of the parameter is passed to the new
1523                   --  entry, so we want to suppress unreferenced warnings.
1524
1525                   Set_Referenced (Ent);
1526                   Next_Formal (Ent);
1527                end loop;
1528             end;
1529          end if;
1530       end if;
1531    end Analyze_Requeue;
1532
1533    ------------------------------
1534    -- Analyze_Selective_Accept --
1535    ------------------------------
1536
1537    procedure Analyze_Selective_Accept (N : Node_Id) is
1538       Alts : constant List_Id := Select_Alternatives (N);
1539       Alt  : Node_Id;
1540
1541       Accept_Present    : Boolean := False;
1542       Terminate_Present : Boolean := False;
1543       Delay_Present     : Boolean := False;
1544       Relative_Present  : Boolean := False;
1545       Alt_Count         : Uint    := Uint_0;
1546
1547    begin
1548       Check_Restriction (No_Select_Statements, N);
1549       Tasking_Used := True;
1550
1551       --  Loop to analyze alternatives
1552
1553       Alt := First (Alts);
1554       while Present (Alt) loop
1555          Alt_Count := Alt_Count + 1;
1556          Analyze (Alt);
1557
1558          if Nkind (Alt) = N_Delay_Alternative then
1559             if Delay_Present then
1560
1561                if Relative_Present /=
1562                    (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1563                then
1564                   Error_Msg_N
1565                     ("delay_until and delay_relative alternatives ", Alt);
1566                   Error_Msg_N
1567                     ("\cannot appear in the same selective_wait", Alt);
1568                end if;
1569
1570             else
1571                Delay_Present := True;
1572                Relative_Present :=
1573                  Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1574             end if;
1575
1576          elsif Nkind (Alt) = N_Terminate_Alternative then
1577             if Terminate_Present then
1578                Error_Msg_N ("only one terminate alternative allowed", N);
1579             else
1580                Terminate_Present := True;
1581                Check_Restriction (No_Terminate_Alternatives, N);
1582             end if;
1583
1584          elsif Nkind (Alt) = N_Accept_Alternative then
1585             Accept_Present := True;
1586
1587             --  Check for duplicate accept
1588
1589             declare
1590                Alt1 : Node_Id;
1591                Stm  : constant Node_Id := Accept_Statement (Alt);
1592                EDN  : constant Node_Id := Entry_Direct_Name (Stm);
1593                Ent  : Entity_Id;
1594
1595             begin
1596                if Nkind (EDN) = N_Identifier
1597                  and then No (Condition (Alt))
1598                  and then Present (Entity (EDN)) -- defend against junk
1599                  and then Ekind (Entity (EDN)) = E_Entry
1600                then
1601                   Ent := Entity (EDN);
1602
1603                   Alt1 := First (Alts);
1604                   while Alt1 /= Alt loop
1605                      if Nkind (Alt1) = N_Accept_Alternative
1606                        and then No (Condition (Alt1))
1607                      then
1608                         declare
1609                            Stm1 : constant Node_Id := Accept_Statement (Alt1);
1610                            EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1611
1612                         begin
1613                            if Nkind (EDN1) = N_Identifier then
1614                               if Entity (EDN1) = Ent then
1615                                  Error_Msg_Sloc := Sloc (Stm1);
1616                                  Error_Msg_N
1617                                    ("?accept duplicates one on line#", Stm);
1618                                  exit;
1619                               end if;
1620                            end if;
1621                         end;
1622                      end if;
1623
1624                      Next (Alt1);
1625                   end loop;
1626                end if;
1627             end;
1628          end if;
1629
1630          Next (Alt);
1631       end loop;
1632
1633       Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1634       Check_Potentially_Blocking_Operation (N);
1635
1636       if Terminate_Present and Delay_Present then
1637          Error_Msg_N ("at most one of terminate or delay alternative", N);
1638
1639       elsif not Accept_Present then
1640          Error_Msg_N
1641            ("select must contain at least one accept alternative", N);
1642       end if;
1643
1644       if Present (Else_Statements (N)) then
1645          if Terminate_Present or Delay_Present then
1646             Error_Msg_N ("else part not allowed with other alternatives", N);
1647          end if;
1648
1649          Analyze_Statements (Else_Statements (N));
1650       end if;
1651    end Analyze_Selective_Accept;
1652
1653    ------------------------------
1654    -- Analyze_Single_Protected --
1655    ------------------------------
1656
1657    procedure Analyze_Single_Protected (N : Node_Id) is
1658       Loc    : constant Source_Ptr := Sloc (N);
1659       Id     : constant Node_Id    := Defining_Identifier (N);
1660       T      : Entity_Id;
1661       T_Decl : Node_Id;
1662       O_Decl : Node_Id;
1663       O_Name : constant Entity_Id := Id;
1664
1665    begin
1666       Generate_Definition (Id);
1667       Tasking_Used := True;
1668
1669       --  The node is rewritten as a protected type declaration, in exact
1670       --  analogy with what is done with single tasks.
1671
1672       T :=
1673         Make_Defining_Identifier (Sloc (Id),
1674           New_External_Name (Chars (Id), 'T'));
1675
1676       T_Decl :=
1677         Make_Protected_Type_Declaration (Loc,
1678          Defining_Identifier => T,
1679          Protected_Definition => Relocate_Node (Protected_Definition (N)),
1680          Interface_List       => Interface_List (N));
1681
1682       O_Decl :=
1683         Make_Object_Declaration (Loc,
1684           Defining_Identifier => O_Name,
1685           Object_Definition   => Make_Identifier (Loc,  Chars (T)));
1686
1687       Rewrite (N, T_Decl);
1688       Insert_After (N, O_Decl);
1689       Mark_Rewrite_Insertion (O_Decl);
1690
1691       --  Enter names of type and object before analysis, because the name of
1692       --  the object may be used in its own body.
1693
1694       Enter_Name (T);
1695       Set_Ekind (T, E_Protected_Type);
1696       Set_Etype (T, T);
1697
1698       Enter_Name (O_Name);
1699       Set_Ekind (O_Name, E_Variable);
1700       Set_Etype (O_Name, T);
1701
1702       --  Instead of calling Analyze on the new node, call the proper analysis
1703       --  procedure directly. Otherwise the node would be expanded twice, with
1704       --  disastrous result.
1705
1706       Analyze_Protected_Type (N);
1707    end Analyze_Single_Protected;
1708
1709    -------------------------
1710    -- Analyze_Single_Task --
1711    -------------------------
1712
1713    procedure Analyze_Single_Task (N : Node_Id) is
1714       Loc    : constant Source_Ptr := Sloc (N);
1715       Id     : constant Node_Id    := Defining_Identifier (N);
1716       T      : Entity_Id;
1717       T_Decl : Node_Id;
1718       O_Decl : Node_Id;
1719       O_Name : constant Entity_Id := Id;
1720
1721    begin
1722       Generate_Definition (Id);
1723       Tasking_Used := True;
1724
1725       --  The node is rewritten as a task type declaration, followed by an
1726       --  object declaration of that anonymous task type.
1727
1728       T :=
1729         Make_Defining_Identifier (Sloc (Id),
1730           New_External_Name (Chars (Id), Suffix => "TK"));
1731
1732       T_Decl :=
1733         Make_Task_Type_Declaration (Loc,
1734           Defining_Identifier => T,
1735           Task_Definition     => Relocate_Node (Task_Definition (N)),
1736           Interface_List      => Interface_List (N));
1737
1738       --  We use the original defining identifier of the single task in the
1739       --  generated object declaration, so that debugging information can
1740       --  be attached to it when compiling with -gnatD. The parent of the
1741       --  entity is the new object declaration. The single_task_declaration
1742       --  is not used further in semantics or code generation, but is scanned
1743       --  when generating debug information, and therefore needs the updated
1744       --  Sloc information for the entity (see Sprint).
1745
1746       O_Decl :=
1747         Make_Object_Declaration (Loc,
1748           Defining_Identifier => O_Name,
1749           Object_Definition   => Make_Identifier (Loc, Chars (T)));
1750
1751       Rewrite (N, T_Decl);
1752       Insert_After (N, O_Decl);
1753       Mark_Rewrite_Insertion (O_Decl);
1754
1755       --  Enter names of type and object before analysis, because the name of
1756       --  the object may be used in its own body.
1757
1758       Enter_Name (T);
1759       Set_Ekind (T, E_Task_Type);
1760       Set_Etype (T, T);
1761
1762       Enter_Name (O_Name);
1763       Set_Ekind (O_Name, E_Variable);
1764       Set_Etype (O_Name, T);
1765
1766       --  Instead of calling Analyze on the new node, call the proper analysis
1767       --  procedure directly. Otherwise the node would be expanded twice, with
1768       --  disastrous result.
1769
1770       Analyze_Task_Type (N);
1771    end Analyze_Single_Task;
1772
1773    -----------------------
1774    -- Analyze_Task_Body --
1775    -----------------------
1776
1777    procedure Analyze_Task_Body (N : Node_Id) is
1778       Body_Id : constant Entity_Id := Defining_Identifier (N);
1779       Decls   : constant List_Id   := Declarations (N);
1780       HSS     : constant Node_Id   := Handled_Statement_Sequence (N);
1781       Last_E  : Entity_Id;
1782
1783       Spec_Id : Entity_Id;
1784       --  This is initially the entity of the task or task type involved, but
1785       --  is replaced by the task type always in the case of a single task
1786       --  declaration, since this is the proper scope to be used.
1787
1788       Ref_Id : Entity_Id;
1789       --  This is the entity of the task or task type, and is the entity used
1790       --  for cross-reference purposes (it differs from Spec_Id in the case of
1791       --  a single task, since Spec_Id is set to the task type)
1792
1793    begin
1794       Tasking_Used := True;
1795       Set_Ekind (Body_Id, E_Task_Body);
1796       Set_Scope (Body_Id, Current_Scope);
1797       Spec_Id := Find_Concurrent_Spec (Body_Id);
1798
1799       --  The spec is either a task type declaration, or a single task
1800       --  declaration for which we have created an anonymous type.
1801
1802       if Present (Spec_Id)
1803         and then Ekind (Spec_Id) = E_Task_Type
1804       then
1805          null;
1806
1807       elsif Present (Spec_Id)
1808         and then Ekind (Etype (Spec_Id)) = E_Task_Type
1809         and then not Comes_From_Source (Etype (Spec_Id))
1810       then
1811          null;
1812
1813       else
1814          Error_Msg_N ("missing specification for task body", Body_Id);
1815          return;
1816       end if;
1817
1818       if Has_Completion (Spec_Id)
1819         and then Present (Corresponding_Body (Parent (Spec_Id)))
1820       then
1821          if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1822             Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1823
1824          else
1825             Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1826          end if;
1827       end if;
1828
1829       Ref_Id := Spec_Id;
1830       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1831       Style.Check_Identifier (Body_Id, Spec_Id);
1832
1833       --  Deal with case of body of single task (anonymous type was created)
1834
1835       if Ekind (Spec_Id) = E_Variable then
1836          Spec_Id := Etype (Spec_Id);
1837       end if;
1838
1839       Push_Scope (Spec_Id);
1840       Set_Corresponding_Spec (N, Spec_Id);
1841       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1842       Set_Has_Completion (Spec_Id);
1843       Install_Declarations (Spec_Id);
1844       Last_E := Last_Entity (Spec_Id);
1845
1846       Analyze_Declarations (Decls);
1847       Inspect_Deferred_Constant_Completion (Decls);
1848
1849       --  For visibility purposes, all entities in the body are private. Set
1850       --  First_Private_Entity accordingly, if there was no private part in the
1851       --  protected declaration.
1852
1853       if No (First_Private_Entity (Spec_Id)) then
1854          if Present (Last_E) then
1855             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1856          else
1857             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1858          end if;
1859       end if;
1860
1861       --  Mark all handlers as not suitable for local raise optimization,
1862       --  since this optimization causes difficulties in a task context.
1863
1864       if Present (Exception_Handlers (HSS)) then
1865          declare
1866             Handlr : Node_Id;
1867          begin
1868             Handlr := First (Exception_Handlers (HSS));
1869             while Present (Handlr) loop
1870                Set_Local_Raise_Not_OK (Handlr);
1871                Next (Handlr);
1872             end loop;
1873          end;
1874       end if;
1875
1876       --  Now go ahead and complete analysis of the task body
1877
1878       Analyze (HSS);
1879       Check_Completion (Body_Id);
1880       Check_References (Body_Id);
1881       Check_References (Spec_Id);
1882
1883       --  Check for entries with no corresponding accept
1884
1885       declare
1886          Ent : Entity_Id;
1887
1888       begin
1889          Ent := First_Entity (Spec_Id);
1890          while Present (Ent) loop
1891             if Is_Entry (Ent)
1892               and then not Entry_Accepted (Ent)
1893               and then Comes_From_Source (Ent)
1894             then
1895                Error_Msg_NE ("no accept for entry &?", N, Ent);
1896             end if;
1897
1898             Next_Entity (Ent);
1899          end loop;
1900       end;
1901
1902       Process_End_Label (HSS, 't', Ref_Id);
1903       End_Scope;
1904    end Analyze_Task_Body;
1905
1906    -----------------------------
1907    -- Analyze_Task_Definition --
1908    -----------------------------
1909
1910    procedure Analyze_Task_Definition (N : Node_Id) is
1911       L : Entity_Id;
1912
1913    begin
1914       Tasking_Used := True;
1915
1916       if Present (Visible_Declarations (N)) then
1917          Analyze_Declarations (Visible_Declarations (N));
1918       end if;
1919
1920       if Present (Private_Declarations (N)) then
1921          L := Last_Entity (Current_Scope);
1922          Analyze_Declarations (Private_Declarations (N));
1923
1924          if Present (L) then
1925             Set_First_Private_Entity
1926               (Current_Scope, Next_Entity (L));
1927          else
1928             Set_First_Private_Entity
1929               (Current_Scope, First_Entity (Current_Scope));
1930          end if;
1931       end if;
1932
1933       Check_Max_Entries (N, Max_Task_Entries);
1934       Process_End_Label (N, 'e', Current_Scope);
1935    end Analyze_Task_Definition;
1936
1937    -----------------------
1938    -- Analyze_Task_Type --
1939    -----------------------
1940
1941    procedure Analyze_Task_Type (N : Node_Id) is
1942       Def_Id : constant Entity_Id := Defining_Identifier (N);
1943       T      : Entity_Id;
1944
1945    begin
1946       Check_Restriction (No_Tasking, N);
1947       Tasking_Used := True;
1948       T := Find_Type_Name (N);
1949       Generate_Definition (T);
1950
1951       --  In the case of an incomplete type, use the full view, unless it's not
1952       --  present (as can occur for an incomplete view from a limited with).
1953
1954       if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1955          T := Full_View (T);
1956          Set_Completion_Referenced (T);
1957       end if;
1958
1959       Set_Ekind              (T, E_Task_Type);
1960       Set_Is_First_Subtype   (T, True);
1961       Set_Has_Task           (T, True);
1962       Init_Size_Align        (T);
1963       Set_Etype              (T, T);
1964       Set_Has_Delayed_Freeze (T, True);
1965       Set_Stored_Constraint  (T, No_Elist);
1966       Push_Scope (T);
1967
1968       if Ada_Version >= Ada_05 then
1969          Check_Interfaces (N, T);
1970       end if;
1971
1972       if Present (Discriminant_Specifications (N)) then
1973          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1974             Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
1975          end if;
1976
1977          if Has_Discriminants (T) then
1978
1979             --  Install discriminants. Also, verify conformance of
1980             --  discriminants of previous and current view. ???
1981
1982             Install_Declarations (T);
1983          else
1984             Process_Discriminants (N);
1985          end if;
1986       end if;
1987
1988       Set_Is_Constrained (T, not Has_Discriminants (T));
1989
1990       if Present (Task_Definition (N)) then
1991          Analyze_Task_Definition (Task_Definition (N));
1992       end if;
1993
1994       --  In the case where the task type is declared at a nested level and the
1995       --  No_Task_Hierarchy restriction applies, issue a warning that objects
1996       --  of the type will violate the restriction.
1997
1998       if not Is_Library_Level_Entity (T)
1999         and then Comes_From_Source (T)
2000         and then Restrictions.Set (No_Task_Hierarchy)
2001       then
2002          Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
2003
2004          if Error_Msg_Sloc = No_Location then
2005             Error_Msg_N
2006               ("objects of this type will violate `No_Task_Hierarchy`?", N);
2007          else
2008             Error_Msg_N
2009               ("objects of this type will violate `No_Task_Hierarchy`?#", N);
2010          end if;
2011       end if;
2012
2013       End_Scope;
2014
2015       --  Case of a completion of a private declaration
2016
2017       if T /= Def_Id
2018         and then Is_Private_Type (Def_Id)
2019       then
2020          --  Deal with preelaborable initialization. Note that this processing
2021          --  is done by Process_Full_View, but as can be seen below, in this
2022          --  case the call to Process_Full_View is skipped if any serious
2023          --  errors have occurred, and we don't want to lose this check.
2024
2025          if Known_To_Have_Preelab_Init (Def_Id) then
2026             Set_Must_Have_Preelab_Init (T);
2027          end if;
2028
2029          --  Create corresponding record now, because some private dependents
2030          --  may be subtypes of the partial view. Skip if errors are present,
2031          --  to prevent cascaded messages.
2032
2033          if Serious_Errors_Detected = 0
2034            and then Expander_Active
2035          then
2036             Expand_N_Task_Type_Declaration (N);
2037             Process_Full_View (N, T, Def_Id);
2038          end if;
2039       end if;
2040    end Analyze_Task_Type;
2041
2042    -----------------------------------
2043    -- Analyze_Terminate_Alternative --
2044    -----------------------------------
2045
2046    procedure Analyze_Terminate_Alternative (N : Node_Id) is
2047    begin
2048       Tasking_Used := True;
2049
2050       if Present (Pragmas_Before (N)) then
2051          Analyze_List (Pragmas_Before (N));
2052       end if;
2053
2054       if Present (Condition (N)) then
2055          Analyze_And_Resolve (Condition (N), Any_Boolean);
2056       end if;
2057    end Analyze_Terminate_Alternative;
2058
2059    ------------------------------
2060    -- Analyze_Timed_Entry_Call --
2061    ------------------------------
2062
2063    procedure Analyze_Timed_Entry_Call (N : Node_Id) is
2064       Trigger        : constant Node_Id :=
2065                          Entry_Call_Statement (Entry_Call_Alternative (N));
2066       Is_Disp_Select : Boolean := False;
2067
2068    begin
2069       Check_Restriction (No_Select_Statements, N);
2070       Tasking_Used := True;
2071
2072       --  Ada 2005 (AI-345): The trigger may be a dispatching call
2073
2074       if Ada_Version >= Ada_05 then
2075          Analyze (Trigger);
2076          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
2077       end if;
2078
2079       --  Postpone the analysis of the statements till expansion. Analyze only
2080       --  if the expander is disabled in order to catch any semantic errors.
2081
2082       if Is_Disp_Select then
2083          if not Expander_Active then
2084             Analyze (Entry_Call_Alternative (N));
2085             Analyze (Delay_Alternative (N));
2086          end if;
2087
2088       --  Regular select analysis
2089
2090       else
2091          Analyze (Entry_Call_Alternative (N));
2092          Analyze (Delay_Alternative (N));
2093       end if;
2094    end Analyze_Timed_Entry_Call;
2095
2096    ------------------------------------
2097    -- Analyze_Triggering_Alternative --
2098    ------------------------------------
2099
2100    procedure Analyze_Triggering_Alternative (N : Node_Id) is
2101       Trigger : constant Node_Id := Triggering_Statement (N);
2102
2103    begin
2104       Tasking_Used := True;
2105
2106       if Present (Pragmas_Before (N)) then
2107          Analyze_List (Pragmas_Before (N));
2108       end if;
2109
2110       Analyze (Trigger);
2111
2112       if Comes_From_Source (Trigger)
2113         and then Nkind (Trigger) not in N_Delay_Statement
2114         and then Nkind (Trigger) /= N_Entry_Call_Statement
2115       then
2116          if Ada_Version < Ada_05 then
2117             Error_Msg_N
2118              ("triggering statement must be delay or entry call", Trigger);
2119
2120          --  Ada 2005 (AI-345): If a procedure_call_statement is used for a
2121          --  procedure_or_entry_call, the procedure_name or procedure_prefix
2122          --  of the procedure_call_statement shall denote an entry renamed by a
2123          --  procedure, or (a view of) a primitive subprogram of a limited
2124          --  interface whose first parameter is a controlling parameter.
2125
2126          elsif Nkind (Trigger) = N_Procedure_Call_Statement
2127            and then not Is_Renamed_Entry (Entity (Name (Trigger)))
2128            and then not Is_Controlling_Limited_Procedure
2129                           (Entity (Name (Trigger)))
2130          then
2131             Error_Msg_N ("triggering statement must be delay, procedure " &
2132                          "or entry call", Trigger);
2133          end if;
2134       end if;
2135
2136       if Is_Non_Empty_List (Statements (N)) then
2137          Analyze_Statements (Statements (N));
2138       end if;
2139    end Analyze_Triggering_Alternative;
2140
2141    -----------------------
2142    -- Check_Max_Entries --
2143    -----------------------
2144
2145    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
2146       Ecount : Uint;
2147
2148       procedure Count (L : List_Id);
2149       --  Count entries in given declaration list
2150
2151       -----------
2152       -- Count --
2153       -----------
2154
2155       procedure Count (L : List_Id) is
2156          D : Node_Id;
2157
2158       begin
2159          if No (L) then
2160             return;
2161          end if;
2162
2163          D := First (L);
2164          while Present (D) loop
2165             if Nkind (D) = N_Entry_Declaration then
2166                declare
2167                   DSD : constant Node_Id :=
2168                           Discrete_Subtype_Definition (D);
2169
2170                begin
2171                   --  If not an entry family, then just one entry
2172
2173                   if No (DSD) then
2174                      Ecount := Ecount + 1;
2175
2176                   --  If entry family with static bounds, count entries
2177
2178                   elsif Is_OK_Static_Subtype (Etype (DSD)) then
2179                      declare
2180                         Lo : constant Uint :=
2181                                Expr_Value
2182                                  (Type_Low_Bound (Etype (DSD)));
2183                         Hi : constant Uint :=
2184                                Expr_Value
2185                                  (Type_High_Bound (Etype (DSD)));
2186
2187                      begin
2188                         if Hi >= Lo then
2189                            Ecount := Ecount + Hi - Lo + 1;
2190                         end if;
2191                      end;
2192
2193                   --  Entry family with non-static bounds
2194
2195                   else
2196                      --  If restriction is set, then this is an error
2197
2198                      if Restrictions.Set (R) then
2199                         Error_Msg_N
2200                           ("static subtype required by Restriction pragma",
2201                            DSD);
2202
2203                      --  Otherwise we record an unknown count restriction
2204
2205                      else
2206                         Check_Restriction (R, D);
2207                      end if;
2208                   end if;
2209                end;
2210             end if;
2211
2212             Next (D);
2213          end loop;
2214       end Count;
2215
2216    --  Start of processing for Check_Max_Entries
2217
2218    begin
2219       Ecount := Uint_0;
2220       Count (Visible_Declarations (D));
2221       Count (Private_Declarations (D));
2222
2223       if Ecount > 0 then
2224          Check_Restriction (R, D, Ecount);
2225       end if;
2226    end Check_Max_Entries;
2227
2228    ----------------------
2229    -- Check_Interfaces --
2230    ----------------------
2231
2232    procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
2233       Iface     : Node_Id;
2234       Iface_Typ : Entity_Id;
2235
2236    begin
2237       pragma Assert
2238         (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
2239
2240       if Present (Interface_List (N)) then
2241          Set_Is_Tagged_Type (T);
2242
2243          Iface := First (Interface_List (N));
2244          while Present (Iface) loop
2245             Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
2246
2247             if not Is_Interface (Iface_Typ) then
2248                Error_Msg_NE
2249                  ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
2250
2251             else
2252                --  Ada 2005 (AI-251): "The declaration of a specific descendant
2253                --  of an interface type freezes the interface type" RM 13.14.
2254
2255                Freeze_Before (N, Etype (Iface));
2256
2257                if Nkind (N) = N_Protected_Type_Declaration then
2258
2259                   --  Ada 2005 (AI-345): Protected types can only implement
2260                   --  limited, synchronized, or protected interfaces (note that
2261                   --  the predicate Is_Limited_Interface includes synchronized
2262                   --  and protected interfaces).
2263
2264                   if Is_Task_Interface (Iface_Typ) then
2265                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
2266                        & "a task interface", Iface);
2267
2268                   elsif not Is_Limited_Interface (Iface_Typ) then
2269                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
2270                        & "a non-limited interface", Iface);
2271                   end if;
2272
2273                else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
2274
2275                   --  Ada 2005 (AI-345): Task types can only implement limited,
2276                   --  synchronized, or task interfaces (note that the predicate
2277                   --  Is_Limited_Interface includes synchronized and task
2278                   --  interfaces).
2279
2280                   if Is_Protected_Interface (Iface_Typ) then
2281                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2282                        "protected interface", Iface);
2283
2284                   elsif not Is_Limited_Interface (Iface_Typ) then
2285                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2286                        "non-limited interface", Iface);
2287                   end if;
2288                end if;
2289             end if;
2290
2291             Next (Iface);
2292          end loop;
2293       end if;
2294
2295       if not Has_Private_Declaration (T) then
2296          return;
2297       end if;
2298
2299       --  Additional checks on full-types associated with private type
2300       --  declarations. Search for the private type declaration.
2301
2302       declare
2303          Full_T_Ifaces : Elist_Id;
2304          Iface         : Node_Id;
2305          Priv_T        : Entity_Id;
2306          Priv_T_Ifaces : Elist_Id;
2307
2308       begin
2309          Priv_T := First_Entity (Scope (T));
2310          loop
2311             pragma Assert (Present (Priv_T));
2312
2313             if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
2314                exit when Full_View (Priv_T) = T;
2315             end if;
2316
2317             Next_Entity (Priv_T);
2318          end loop;
2319
2320          --  In case of synchronized types covering interfaces the private type
2321          --  declaration must be limited.
2322
2323          if Present (Interface_List (N))
2324            and then not Is_Limited_Record (Priv_T)
2325          then
2326             Error_Msg_Sloc := Sloc (Priv_T);
2327             Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
2328                          "private type#", T);
2329          end if;
2330
2331          --  RM 7.3 (7.1/2): If the full view has a partial view that is
2332          --  tagged then check RM 7.3 subsidiary rules.
2333
2334          if Is_Tagged_Type (Priv_T)
2335            and then not Error_Posted (N)
2336          then
2337             --  RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2338             --  type if and only if the full type is a synchronized tagged type
2339
2340             if Is_Synchronized_Tagged_Type (Priv_T)
2341               and then not Is_Synchronized_Tagged_Type (T)
2342             then
2343                Error_Msg_N
2344                  ("(Ada 2005) full view must be a synchronized tagged " &
2345                   "type (RM 7.3 (7.2/2))", Priv_T);
2346
2347             elsif Is_Synchronized_Tagged_Type (T)
2348               and then not Is_Synchronized_Tagged_Type (Priv_T)
2349             then
2350                Error_Msg_N
2351                  ("(Ada 2005) partial view must be a synchronized tagged " &
2352                   "type (RM 7.3 (7.2/2))", T);
2353             end if;
2354
2355             --  RM 7.3 (7.3/2): The partial view shall be a descendant of an
2356             --  interface type if and only if the full type is descendant of
2357             --  the interface type.
2358
2359             if Present (Interface_List (N))
2360               or else (Is_Tagged_Type (Priv_T)
2361                          and then Has_Interfaces
2362                                    (Priv_T, Use_Full_View => False))
2363             then
2364                if Is_Tagged_Type (Priv_T) then
2365                   Collect_Interfaces
2366                     (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
2367                end if;
2368
2369                if Is_Tagged_Type (T) then
2370                   Collect_Interfaces (T, Full_T_Ifaces);
2371                end if;
2372
2373                Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
2374
2375                if Present (Iface) then
2376                   Error_Msg_NE
2377                     ("interface & not implemented by full type " &
2378                      "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
2379                end if;
2380
2381                Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
2382
2383                if Present (Iface) then
2384                   Error_Msg_NE
2385                     ("interface & not implemented by partial " &
2386                      "view (RM-2005 7.3 (7.3/2))", T, Iface);
2387                end if;
2388             end if;
2389          end if;
2390       end;
2391    end Check_Interfaces;
2392
2393    --------------------------------
2394    -- Check_Triggering_Statement --
2395    --------------------------------
2396
2397    procedure Check_Triggering_Statement
2398      (Trigger        : Node_Id;
2399       Error_Node     : Node_Id;
2400       Is_Dispatching : out Boolean)
2401    is
2402       Param : Node_Id;
2403
2404    begin
2405       Is_Dispatching := False;
2406
2407       --  It is not possible to have a dispatching trigger if we are not in
2408       --  Ada 2005 mode.
2409
2410       if Ada_Version >= Ada_05
2411         and then Nkind (Trigger) = N_Procedure_Call_Statement
2412         and then Present (Parameter_Associations (Trigger))
2413       then
2414          Param := First (Parameter_Associations (Trigger));
2415
2416          if Is_Controlling_Actual (Param)
2417            and then Is_Interface (Etype (Param))
2418          then
2419             if Is_Limited_Record (Etype (Param)) then
2420                Is_Dispatching := True;
2421             else
2422                Error_Msg_N
2423                  ("dispatching operation of limited or synchronized " &
2424                   "interface required (RM 9.7.2(3))!", Error_Node);
2425             end if;
2426          end if;
2427       end if;
2428    end Check_Triggering_Statement;
2429
2430    --------------------------
2431    -- Find_Concurrent_Spec --
2432    --------------------------
2433
2434    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2435       Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2436
2437    begin
2438       --  The type may have been given by an incomplete type declaration.
2439       --  Find full view now.
2440
2441       if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2442          Spec_Id := Full_View (Spec_Id);
2443       end if;
2444
2445       return Spec_Id;
2446    end Find_Concurrent_Spec;
2447
2448    --------------------------
2449    -- Install_Declarations --
2450    --------------------------
2451
2452    procedure Install_Declarations (Spec : Entity_Id) is
2453       E    : Entity_Id;
2454       Prev : Entity_Id;
2455    begin
2456       E := First_Entity (Spec);
2457       while Present (E) loop
2458          Prev := Current_Entity (E);
2459          Set_Current_Entity (E);
2460          Set_Is_Immediately_Visible (E);
2461          Set_Homonym (E, Prev);
2462          Next_Entity (E);
2463       end loop;
2464    end Install_Declarations;
2465
2466 end Sem_Ch9;