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