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