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-2012, 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
 909          --  Check entry family static bounds outside allowed limits
 910
 911          --  Note: originally this check was not performed here, but in that
 912          --  case the check happens deep in the expander, and the message is
 913          --  posted at the wrong location, and omitted in -gnatc mode.
 914          --  If the type of the entry index is a generic formal, no check
 915          --  is possible. In an instance, the check is not static and a run-
 916          --  time exception will be raised if the bounds are unreasonable.
 917
 918          declare
 919             PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
 920             LB  : constant Uint      := Expr_Value (Type_Low_Bound (PEI));
 921             UB  : constant Uint      := Expr_Value (Type_High_Bound (PEI));
 922
 923             LBR : Node_Id;
 924             UBR : Node_Id;
 925
 926          begin
 927
 928             --  No bounds checking if the type is generic or if previous error.
 929             --  In an instance the check is dynamic.
 930
 931             if Is_Generic_Type (Etype (D_Sdef))
 932               or else In_Instance
 933               or else Error_Posted (D_Sdef)
 934             then
 935                goto Skip_LB;
 936
 937             elsif Nkind (D_Sdef) = N_Range then
 938                LBR := Low_Bound (D_Sdef);
 939
 940             elsif Is_Entity_Name (D_Sdef)
 941               and then Is_Type (Entity (D_Sdef))
 942             then
 943                LBR := Type_Low_Bound (Entity (D_Sdef));
 944
 945             else
 946                goto Skip_LB;
 947             end if;
 948
 949             if Is_Static_Expression (LBR)
 950               and then Expr_Value (LBR) < LB
 951             then
 952                Error_Msg_Uint_1 := LB;
 953                Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
 954             end if;
 955
 956          <<Skip_LB>>
 957             if Is_Generic_Type (Etype (D_Sdef))
 958               or else In_Instance
 959               or else Error_Posted (D_Sdef)
 960             then
 961                goto Skip_UB;
 962
 963             elsif Nkind (D_Sdef) = N_Range then
 964                UBR := High_Bound (D_Sdef);
 965
 966             elsif Is_Entity_Name (D_Sdef)
 967               and then Is_Type (Entity (D_Sdef))
 968             then
 969                UBR := Type_High_Bound (Entity (D_Sdef));
 970
 971             else
 972                goto Skip_UB;
 973             end if;
 974
 975             if Is_Static_Expression (UBR)
 976               and then Expr_Value (UBR) > UB
 977             then
 978                Error_Msg_Uint_1 := UB;
 979                Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
 980             end if;
 981
 982          <<Skip_UB>>
 983             null;
 984          end;
 985       end if;
 986
 987       --  Decorate Def_Id
 988
 989       Set_Etype          (Def_Id, Standard_Void_Type);
 990       Set_Convention     (Def_Id, Convention_Entry);
 991       Set_Accept_Address (Def_Id, New_Elmt_List);
 992
 993       --  Process formals
 994
 995       if Present (Formals) then
 996          Set_Scope (Def_Id, Current_Scope);
 997          Push_Scope (Def_Id);
 998          Process_Formals (Formals, N);
 999          Create_Extra_Formals (Def_Id);
1000          End_Scope;
1001       end if;
1002
1003       if Ekind (Def_Id) = E_Entry then
1004          New_Overloaded_Entity (Def_Id);
1005       end if;
1006
1007       Generate_Reference_To_Formals (Def_Id);
1008
1009       if Has_Aspects (N) then
1010          Analyze_Aspect_Specifications (N, Def_Id);
1011       end if;
1012    end Analyze_Entry_Declaration;
1013
1014    ---------------------------------------
1015    -- Analyze_Entry_Index_Specification --
1016    ---------------------------------------
1017
1018    --  The Defining_Identifier of the entry index specification is local to the
1019    --  entry body, but it must be available in the entry barrier which is
1020    --  evaluated outside of the entry body. The index is eventually renamed as
1021    --  a run-time object, so is visibility is strictly a front-end concern. In
1022    --  order to make it available to the barrier, we create an additional
1023    --  scope, as for a loop, whose only declaration is the index name. This
1024    --  loop is not attached to the tree and does not appear as an entity local
1025    --  to the protected type, so its existence need only be known to routines
1026    --  that process entry families.
1027
1028    procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1029       Iden    : constant Node_Id   := Defining_Identifier (N);
1030       Def     : constant Node_Id   := Discrete_Subtype_Definition (N);
1031       Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
1032
1033    begin
1034       Tasking_Used := True;
1035       Analyze (Def);
1036
1037       --  There is no elaboration of the entry index specification. Therefore,
1038       --  if the index is a range, it is not resolved and expanded, but the
1039       --  bounds are inherited from the entry declaration, and reanalyzed.
1040       --  See Analyze_Entry_Body.
1041
1042       if Nkind (Def) /= N_Range then
1043          Make_Index (Def, N);
1044       end if;
1045
1046       Set_Ekind (Loop_Id, E_Loop);
1047       Set_Scope (Loop_Id, Current_Scope);
1048       Push_Scope (Loop_Id);
1049       Enter_Name (Iden);
1050       Set_Ekind (Iden, E_Entry_Index_Parameter);
1051       Set_Etype (Iden, Etype (Def));
1052    end Analyze_Entry_Index_Specification;
1053
1054    ----------------------------
1055    -- Analyze_Protected_Body --
1056    ----------------------------
1057
1058    procedure Analyze_Protected_Body (N : Node_Id) is
1059       Body_Id : constant Entity_Id := Defining_Identifier (N);
1060       Last_E  : Entity_Id;
1061
1062       Spec_Id : Entity_Id;
1063       --  This is initially the entity of the protected object or protected
1064       --  type involved, but is replaced by the protected type always in the
1065       --  case of a single protected declaration, since this is the proper
1066       --  scope to be used.
1067
1068       Ref_Id : Entity_Id;
1069       --  This is the entity of the protected object or protected type
1070       --  involved, and is the entity used for cross-reference purposes (it
1071       --  differs from Spec_Id in the case of a single protected object, since
1072       --  Spec_Id is set to the protected type in this case).
1073
1074    begin
1075       Tasking_Used := True;
1076       Set_Ekind (Body_Id, E_Protected_Body);
1077       Spec_Id := Find_Concurrent_Spec (Body_Id);
1078
1079       if Present (Spec_Id)
1080         and then Ekind (Spec_Id) = E_Protected_Type
1081       then
1082          null;
1083
1084       elsif Present (Spec_Id)
1085         and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1086         and then not Comes_From_Source (Etype (Spec_Id))
1087       then
1088          null;
1089
1090       else
1091          Error_Msg_N ("missing specification for protected body", Body_Id);
1092          return;
1093       end if;
1094
1095       Ref_Id := Spec_Id;
1096       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1097       Style.Check_Identifier (Body_Id, Spec_Id);
1098
1099       --  The declarations are always attached to the type
1100
1101       if Ekind (Spec_Id) /= E_Protected_Type then
1102          Spec_Id := Etype (Spec_Id);
1103       end if;
1104
1105       Push_Scope (Spec_Id);
1106       Set_Corresponding_Spec (N, Spec_Id);
1107       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1108       Set_Has_Completion (Spec_Id);
1109       Install_Declarations (Spec_Id);
1110
1111       Expand_Protected_Body_Declarations (N, Spec_Id);
1112
1113       Last_E := Last_Entity (Spec_Id);
1114
1115       Analyze_Declarations (Declarations (N));
1116
1117       --  For visibility purposes, all entities in the body are private. Set
1118       --  First_Private_Entity accordingly, if there was no private part in the
1119       --  protected declaration.
1120
1121       if No (First_Private_Entity (Spec_Id)) then
1122          if Present (Last_E) then
1123             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1124          else
1125             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1126          end if;
1127       end if;
1128
1129       Check_Completion (Body_Id);
1130       Check_References (Spec_Id);
1131       Process_End_Label (N, 't', Ref_Id);
1132       End_Scope;
1133    end Analyze_Protected_Body;
1134
1135    ----------------------------------
1136    -- Analyze_Protected_Definition --
1137    ----------------------------------
1138
1139    procedure Analyze_Protected_Definition (N : Node_Id) is
1140       E : Entity_Id;
1141       L : Entity_Id;
1142
1143       procedure Undelay_Itypes (T : Entity_Id);
1144       --  Itypes created for the private components of a protected type
1145       --  do not receive freeze nodes, because there is no scope in which
1146       --  they can be elaborated, and they can depend on discriminants of
1147       --  the enclosed protected type. Given that the components can be
1148       --  composite types with inner components, we traverse recursively
1149       --  the private components of the protected type, and indicate that
1150       --  all itypes within are frozen. This ensures that no freeze nodes
1151       --  will be generated for them.
1152       --
1153       --  On the other hand, components of the corresponding record are
1154       --  frozen (or receive itype references) as for other records.
1155
1156       --------------------
1157       -- Undelay_Itypes --
1158       --------------------
1159
1160       procedure Undelay_Itypes (T : Entity_Id) is
1161          Comp : Entity_Id;
1162
1163       begin
1164          if Is_Protected_Type (T) then
1165             Comp := First_Private_Entity (T);
1166          elsif Is_Record_Type (T) then
1167             Comp := First_Entity (T);
1168          else
1169             return;
1170          end if;
1171
1172          while Present (Comp) loop
1173             if Is_Type (Comp)
1174               and then Is_Itype (Comp)
1175             then
1176                Set_Has_Delayed_Freeze (Comp, False);
1177                Set_Is_Frozen (Comp);
1178
1179                if Is_Record_Type (Comp)
1180                  or else Is_Protected_Type (Comp)
1181                then
1182                   Undelay_Itypes (Comp);
1183                end if;
1184             end if;
1185
1186             Next_Entity (Comp);
1187          end loop;
1188       end Undelay_Itypes;
1189
1190    --  Start of processing for Analyze_Protected_Definition
1191
1192    begin
1193       Tasking_Used := True;
1194       Check_SPARK_Restriction ("protected definition is not allowed", N);
1195       Analyze_Declarations (Visible_Declarations (N));
1196
1197       if Present (Private_Declarations (N))
1198         and then not Is_Empty_List (Private_Declarations (N))
1199       then
1200          L := Last_Entity (Current_Scope);
1201          Analyze_Declarations (Private_Declarations (N));
1202
1203          if Present (L) then
1204             Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1205          else
1206             Set_First_Private_Entity (Current_Scope,
1207               First_Entity (Current_Scope));
1208          end if;
1209       end if;
1210
1211       E := First_Entity (Current_Scope);
1212       while Present (E) loop
1213          if Ekind_In (E, E_Function, E_Procedure) then
1214             Set_Convention (E, Convention_Protected);
1215
1216          elsif Is_Task_Type (Etype (E))
1217            or else Has_Task (Etype (E))
1218          then
1219             Set_Has_Task (Current_Scope);
1220          end if;
1221
1222          Next_Entity (E);
1223       end loop;
1224
1225       Undelay_Itypes (Current_Scope);
1226
1227       Check_Max_Entries (N, Max_Protected_Entries);
1228       Process_End_Label (N, 'e', Current_Scope);
1229    end Analyze_Protected_Definition;
1230
1231    ----------------------------------------
1232    -- Analyze_Protected_Type_Declaration --
1233    ----------------------------------------
1234
1235    procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
1236       Def_Id : constant Entity_Id := Defining_Identifier (N);
1237       E      : Entity_Id;
1238       T      : Entity_Id;
1239
1240    begin
1241       if No_Run_Time_Mode then
1242          Error_Msg_CRT ("protected type", N);
1243
1244          if Has_Aspects (N) then
1245             Analyze_Aspect_Specifications (N, Def_Id);
1246          end if;
1247
1248          return;
1249       end if;
1250
1251       Tasking_Used := True;
1252       Check_Restriction (No_Protected_Types, N);
1253
1254       T := Find_Type_Name (N);
1255
1256       --  In the case of an incomplete type, use the full view, unless it's not
1257       --  present (as can occur for an incomplete view from a limited with).
1258
1259       if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1260          T := Full_View (T);
1261          Set_Completion_Referenced (T);
1262       end if;
1263
1264       Set_Ekind              (T, E_Protected_Type);
1265       Set_Is_First_Subtype   (T, True);
1266       Init_Size_Align        (T);
1267       Set_Etype              (T, T);
1268       Set_Has_Delayed_Freeze (T, True);
1269       Set_Stored_Constraint  (T, No_Elist);
1270       Push_Scope (T);
1271
1272       if Ada_Version >= Ada_2005 then
1273          Check_Interfaces (N, T);
1274       end if;
1275
1276       if Present (Discriminant_Specifications (N)) then
1277          if Has_Discriminants (T) then
1278
1279             --  Install discriminants. Also, verify conformance of
1280             --  discriminants of previous and current view. ???
1281
1282             Install_Declarations (T);
1283          else
1284             Process_Discriminants (N);
1285          end if;
1286       end if;
1287
1288       Set_Is_Constrained (T, not Has_Discriminants (T));
1289
1290       --  If aspects are present, analyze them now. They can make references
1291       --  to the discriminants of the type, but not to any components.
1292
1293       if Has_Aspects (N) then
1294          Analyze_Aspect_Specifications (N, Def_Id);
1295       end if;
1296
1297       Analyze (Protected_Definition (N));
1298
1299       --  In the case where the protected type is declared at a nested level
1300       --  and the No_Local_Protected_Objects restriction applies, issue a
1301       --  warning that objects of the type will violate the restriction.
1302
1303       if Restriction_Check_Required (No_Local_Protected_Objects)
1304         and then not Is_Library_Level_Entity (T)
1305         and then Comes_From_Source (T)
1306       then
1307          Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
1308
1309          if Error_Msg_Sloc = No_Location then
1310             Error_Msg_N
1311               ("objects of this type will violate " &
1312                "`No_Local_Protected_Objects`?", N);
1313          else
1314             Error_Msg_N
1315               ("objects of this type will violate " &
1316                "`No_Local_Protected_Objects`?#", N);
1317          end if;
1318       end if;
1319
1320       --  Protected types with entries are controlled (because of the
1321       --  Protection component if nothing else), same for any protected type
1322       --  with interrupt handlers. Note that we need to analyze the protected
1323       --  definition to set Has_Entries and such.
1324
1325       if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1326            or else Number_Entries (T) > 1)
1327         and then
1328           (Has_Entries (T)
1329             or else Has_Interrupt_Handler (T)
1330             or else Has_Attach_Handler (T))
1331       then
1332          Set_Has_Controlled_Component (T, True);
1333       end if;
1334
1335       --  The Ekind of components is E_Void during analysis to detect illegal
1336       --  uses. Now it can be set correctly.
1337
1338       E := First_Entity (Current_Scope);
1339       while Present (E) loop
1340          if Ekind (E) = E_Void then
1341             Set_Ekind (E, E_Component);
1342             Init_Component_Location (E);
1343          end if;
1344
1345          Next_Entity (E);
1346       end loop;
1347
1348       End_Scope;
1349
1350       --  Case of a completion of a private declaration
1351
1352       if T /= Def_Id
1353         and then Is_Private_Type (Def_Id)
1354       then
1355          --  Deal with preelaborable initialization. Note that this processing
1356          --  is done by Process_Full_View, but as can be seen below, in this
1357          --  case the call to Process_Full_View is skipped if any serious
1358          --  errors have occurred, and we don't want to lose this check.
1359
1360          if Known_To_Have_Preelab_Init (Def_Id) then
1361             Set_Must_Have_Preelab_Init (T);
1362          end if;
1363
1364          --  Create corresponding record now, because some private dependents
1365          --  may be subtypes of the partial view.
1366
1367          --  Skip if errors are present, to prevent cascaded messages
1368
1369          if Serious_Errors_Detected = 0
1370
1371            --  Also skip if expander is not active
1372
1373            and then Full_Expander_Active
1374          then
1375             Expand_N_Protected_Type_Declaration (N);
1376             Process_Full_View (N, T, Def_Id);
1377          end if;
1378       end if;
1379    end Analyze_Protected_Type_Declaration;
1380
1381    ---------------------
1382    -- Analyze_Requeue --
1383    ---------------------
1384
1385    procedure Analyze_Requeue (N : Node_Id) is
1386       Count       : Natural := 0;
1387       Entry_Name  : Node_Id := Name (N);
1388       Entry_Id    : Entity_Id;
1389       I           : Interp_Index;
1390       Is_Disp_Req : Boolean;
1391       It          : Interp;
1392       Enclosing   : Entity_Id;
1393       Target_Obj  : Node_Id := Empty;
1394       Req_Scope   : Entity_Id;
1395       Outer_Ent   : Entity_Id;
1396       Synch_Type  : Entity_Id;
1397
1398    begin
1399       Tasking_Used := True;
1400       Check_SPARK_Restriction ("requeue statement is not allowed", N);
1401       Check_Restriction (No_Requeue_Statements, N);
1402       Check_Unreachable_Code (N);
1403
1404       Enclosing := Empty;
1405       for J in reverse 0 .. Scope_Stack.Last loop
1406          Enclosing := Scope_Stack.Table (J).Entity;
1407          exit when Is_Entry (Enclosing);
1408
1409          if not Ekind_In (Enclosing, E_Block, E_Loop) then
1410             Error_Msg_N ("requeue must appear within accept or entry body", N);
1411             return;
1412          end if;
1413       end loop;
1414
1415       Analyze (Entry_Name);
1416
1417       if Etype (Entry_Name) = Any_Type then
1418          return;
1419       end if;
1420
1421       if Nkind (Entry_Name) = N_Selected_Component then
1422          Target_Obj := Prefix (Entry_Name);
1423          Entry_Name := Selector_Name (Entry_Name);
1424       end if;
1425
1426       --  If an explicit target object is given then we have to check the
1427       --  restrictions of 9.5.4(6).
1428
1429       if Present (Target_Obj) then
1430
1431          --  Locate containing concurrent unit and determine enclosing entry
1432          --  body or outermost enclosing accept statement within the unit.
1433
1434          Outer_Ent := Empty;
1435          for S in reverse 0 .. Scope_Stack.Last loop
1436             Req_Scope := Scope_Stack.Table (S).Entity;
1437
1438             exit when Ekind (Req_Scope) in Task_Kind
1439               or else Ekind (Req_Scope) in Protected_Kind;
1440
1441             if Is_Entry (Req_Scope) then
1442                Outer_Ent := Req_Scope;
1443             end if;
1444          end loop;
1445
1446          pragma Assert (Present (Outer_Ent));
1447
1448          --  Check that the accessibility level of the target object is not
1449          --  greater or equal to the outermost enclosing accept statement (or
1450          --  entry body) unless it is a parameter of the innermost enclosing
1451          --  accept statement (or entry body).
1452
1453          if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1454            and then
1455              (not Is_Entity_Name (Target_Obj)
1456                or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1457                or else Enclosing /= Scope (Entity (Target_Obj)))
1458          then
1459             Error_Msg_N
1460               ("target object has invalid level for requeue", Target_Obj);
1461          end if;
1462       end if;
1463
1464       --  Overloaded case, find right interpretation
1465
1466       if Is_Overloaded (Entry_Name) then
1467          Entry_Id := Empty;
1468
1469          --  Loop over candidate interpretations and filter out any that are
1470          --  not parameterless, are not type conformant, are not entries, or
1471          --  do not come from source.
1472
1473          Get_First_Interp (Entry_Name, I, It);
1474          while Present (It.Nam) loop
1475
1476             --  Note: we test type conformance here, not subtype conformance.
1477             --  Subtype conformance will be tested later on, but it is better
1478             --  for error output in some cases not to do that here.
1479
1480             if (No (First_Formal (It.Nam))
1481                  or else (Type_Conformant (Enclosing, It.Nam)))
1482               and then Ekind (It.Nam) = E_Entry
1483             then
1484                --  Ada 2005 (AI-345): Since protected and task types have
1485                --  primitive entry wrappers, we only consider source entries.
1486
1487                if Comes_From_Source (It.Nam) then
1488                   Count := Count + 1;
1489                   Entry_Id := It.Nam;
1490                else
1491                   Remove_Interp (I);
1492                end if;
1493             end if;
1494
1495             Get_Next_Interp (I, It);
1496          end loop;
1497
1498          if Count = 0 then
1499             Error_Msg_N ("no entry matches context", N);
1500             return;
1501
1502          elsif Count > 1 then
1503             Error_Msg_N ("ambiguous entry name in requeue", N);
1504             return;
1505
1506          else
1507             Set_Is_Overloaded (Entry_Name, False);
1508             Set_Entity (Entry_Name, Entry_Id);
1509          end if;
1510
1511       --  Non-overloaded cases
1512
1513       --  For the case of a reference to an element of an entry family, the
1514       --  Entry_Name is an indexed component.
1515
1516       elsif Nkind (Entry_Name) = N_Indexed_Component then
1517
1518          --  Requeue to an entry out of the body
1519
1520          if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1521             Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1522
1523          --  Requeue from within the body itself
1524
1525          elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1526             Entry_Id := Entity (Prefix (Entry_Name));
1527
1528          else
1529             Error_Msg_N ("invalid entry_name specified",  N);
1530             return;
1531          end if;
1532
1533       --  If we had a requeue of the form REQUEUE A (B), then the parser
1534       --  accepted it (because it could have been a requeue on an entry index.
1535       --  If A turns out not to be an entry family, then the analysis of A (B)
1536       --  turned it into a function call.
1537
1538       elsif Nkind (Entry_Name) = N_Function_Call then
1539          Error_Msg_N
1540            ("arguments not allowed in requeue statement",
1541             First (Parameter_Associations (Entry_Name)));
1542          return;
1543
1544       --  Normal case of no entry family, no argument
1545
1546       else
1547          Entry_Id := Entity (Entry_Name);
1548       end if;
1549
1550       --  Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
1551       --  target type must be a concurrent interface class-wide type and the
1552       --  target must be a procedure, flagged by pragma Implemented. The
1553       --  target may be an access to class-wide type, in which case it must
1554       --  be dereferenced.
1555
1556       if Present (Target_Obj) then
1557          Synch_Type := Etype (Target_Obj);
1558
1559          if Is_Access_Type (Synch_Type) then
1560             Synch_Type := Designated_Type (Synch_Type);
1561          end if;
1562       end if;
1563
1564       Is_Disp_Req :=
1565         Ada_Version >= Ada_2012
1566           and then Present (Target_Obj)
1567           and then Is_Class_Wide_Type (Synch_Type)
1568           and then Is_Concurrent_Interface (Synch_Type)
1569           and then Ekind (Entry_Id) = E_Procedure
1570           and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
1571
1572       --  Resolve entry, and check that it is subtype conformant with the
1573       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
1574       --  Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1575
1576       if not Is_Entry (Entry_Id)
1577         and then not Is_Disp_Req
1578       then
1579          Error_Msg_N ("expect entry name in requeue statement", Name (N));
1580
1581       elsif Ekind (Entry_Id) = E_Entry_Family
1582         and then Nkind (Entry_Name) /= N_Indexed_Component
1583       then
1584          Error_Msg_N ("missing index for entry family component", Name (N));
1585
1586       else
1587          Resolve_Entry (Name (N));
1588          Generate_Reference (Entry_Id, Entry_Name);
1589
1590          if Present (First_Formal (Entry_Id)) then
1591             if VM_Target = JVM_Target then
1592                Error_Msg_N
1593                  ("arguments unsupported in requeue statement",
1594                   First_Formal (Entry_Id));
1595                return;
1596             end if;
1597
1598             --  Ada 2012 (AI05-0030): Perform type conformance after skipping
1599             --  the first parameter of Entry_Id since it is the interface
1600             --  controlling formal.
1601
1602             if Ada_Version >= Ada_2012
1603               and then Is_Disp_Req
1604             then
1605                declare
1606                   Enclosing_Formal : Entity_Id;
1607                   Target_Formal    : Entity_Id;
1608
1609                begin
1610                   Enclosing_Formal := First_Formal (Enclosing);
1611                   Target_Formal := Next_Formal (First_Formal (Entry_Id));
1612                   while Present (Enclosing_Formal)
1613                     and then Present (Target_Formal)
1614                   loop
1615                      if not Conforming_Types
1616                               (T1    => Etype (Enclosing_Formal),
1617                                T2    => Etype (Target_Formal),
1618                                Ctype => Subtype_Conformant)
1619                      then
1620                         Error_Msg_Node_2 := Target_Formal;
1621                         Error_Msg_NE
1622                           ("formal & is not subtype conformant with &" &
1623                            "in dispatching requeue", N, Enclosing_Formal);
1624                      end if;
1625
1626                      Next_Formal (Enclosing_Formal);
1627                      Next_Formal (Target_Formal);
1628                   end loop;
1629                end;
1630             else
1631                Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1632             end if;
1633
1634             --  Processing for parameters accessed by the requeue
1635
1636             declare
1637                Ent : Entity_Id;
1638
1639             begin
1640                Ent := First_Formal (Enclosing);
1641                while Present (Ent) loop
1642
1643                   --  For OUT or IN OUT parameter, the effect of the requeue is
1644                   --  to assign the parameter a value on exit from the requeued
1645                   --  body, so we can set it as source assigned. We also clear
1646                   --  the Is_True_Constant indication. We do not need to clear
1647                   --  Current_Value, since the effect of the requeue is to
1648                   --  perform an unconditional goto so that any further
1649                   --  references will not occur anyway.
1650
1651                   if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
1652                      Set_Never_Set_In_Source (Ent, False);
1653                      Set_Is_True_Constant    (Ent, False);
1654                   end if;
1655
1656                   --  For all parameters, the requeue acts as a reference,
1657                   --  since the value of the parameter is passed to the new
1658                   --  entry, so we want to suppress unreferenced warnings.
1659
1660                   Set_Referenced (Ent);
1661                   Next_Formal (Ent);
1662                end loop;
1663             end;
1664          end if;
1665       end if;
1666    end Analyze_Requeue;
1667
1668    ------------------------------
1669    -- Analyze_Selective_Accept --
1670    ------------------------------
1671
1672    procedure Analyze_Selective_Accept (N : Node_Id) is
1673       Alts : constant List_Id := Select_Alternatives (N);
1674       Alt  : Node_Id;
1675
1676       Accept_Present    : Boolean := False;
1677       Terminate_Present : Boolean := False;
1678       Delay_Present     : Boolean := False;
1679       Relative_Present  : Boolean := False;
1680       Alt_Count         : Uint    := Uint_0;
1681
1682    begin
1683       Tasking_Used := True;
1684       Check_SPARK_Restriction ("select statement is not allowed", N);
1685       Check_Restriction (No_Select_Statements, N);
1686
1687       --  Loop to analyze alternatives
1688
1689       Alt := First (Alts);
1690       while Present (Alt) loop
1691          Alt_Count := Alt_Count + 1;
1692          Analyze (Alt);
1693
1694          if Nkind (Alt) = N_Delay_Alternative then
1695             if Delay_Present then
1696
1697                if Relative_Present /=
1698                    (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1699                then
1700                   Error_Msg_N
1701                     ("delay_until and delay_relative alternatives ", Alt);
1702                   Error_Msg_N
1703                     ("\cannot appear in the same selective_wait", Alt);
1704                end if;
1705
1706             else
1707                Delay_Present := True;
1708                Relative_Present :=
1709                  Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1710             end if;
1711
1712          elsif Nkind (Alt) = N_Terminate_Alternative then
1713             if Terminate_Present then
1714                Error_Msg_N ("only one terminate alternative allowed", N);
1715             else
1716                Terminate_Present := True;
1717                Check_Restriction (No_Terminate_Alternatives, N);
1718             end if;
1719
1720          elsif Nkind (Alt) = N_Accept_Alternative then
1721             Accept_Present := True;
1722
1723             --  Check for duplicate accept
1724
1725             declare
1726                Alt1 : Node_Id;
1727                Stm  : constant Node_Id := Accept_Statement (Alt);
1728                EDN  : constant Node_Id := Entry_Direct_Name (Stm);
1729                Ent  : Entity_Id;
1730
1731             begin
1732                if Nkind (EDN) = N_Identifier
1733                  and then No (Condition (Alt))
1734                  and then Present (Entity (EDN)) -- defend against junk
1735                  and then Ekind (Entity (EDN)) = E_Entry
1736                then
1737                   Ent := Entity (EDN);
1738
1739                   Alt1 := First (Alts);
1740                   while Alt1 /= Alt loop
1741                      if Nkind (Alt1) = N_Accept_Alternative
1742                        and then No (Condition (Alt1))
1743                      then
1744                         declare
1745                            Stm1 : constant Node_Id := Accept_Statement (Alt1);
1746                            EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1747
1748                         begin
1749                            if Nkind (EDN1) = N_Identifier then
1750                               if Entity (EDN1) = Ent then
1751                                  Error_Msg_Sloc := Sloc (Stm1);
1752                                  Error_Msg_N
1753                                    ("?accept duplicates one on line#", Stm);
1754                                  exit;
1755                               end if;
1756                            end if;
1757                         end;
1758                      end if;
1759
1760                      Next (Alt1);
1761                   end loop;
1762                end if;
1763             end;
1764          end if;
1765
1766          Next (Alt);
1767       end loop;
1768
1769       Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1770       Check_Potentially_Blocking_Operation (N);
1771
1772       if Terminate_Present and Delay_Present then
1773          Error_Msg_N ("at most one of terminate or delay alternative", N);
1774
1775       elsif not Accept_Present then
1776          Error_Msg_N
1777            ("select must contain at least one accept alternative", N);
1778       end if;
1779
1780       if Present (Else_Statements (N)) then
1781          if Terminate_Present or Delay_Present then
1782             Error_Msg_N ("else part not allowed with other alternatives", N);
1783          end if;
1784
1785          Analyze_Statements (Else_Statements (N));
1786       end if;
1787    end Analyze_Selective_Accept;
1788
1789    ------------------------------------------
1790    -- Analyze_Single_Protected_Declaration --
1791    ------------------------------------------
1792
1793    procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
1794       Loc    : constant Source_Ptr := Sloc (N);
1795       Id     : constant Node_Id    := Defining_Identifier (N);
1796       T      : Entity_Id;
1797       T_Decl : Node_Id;
1798       O_Decl : Node_Id;
1799       O_Name : constant Entity_Id := Id;
1800
1801    begin
1802       Generate_Definition (Id);
1803       Tasking_Used := True;
1804
1805       --  The node is rewritten as a protected type declaration, in exact
1806       --  analogy with what is done with single tasks.
1807
1808       T :=
1809         Make_Defining_Identifier (Sloc (Id),
1810           New_External_Name (Chars (Id), 'T'));
1811
1812       T_Decl :=
1813         Make_Protected_Type_Declaration (Loc,
1814          Defining_Identifier => T,
1815          Protected_Definition => Relocate_Node (Protected_Definition (N)),
1816          Interface_List       => Interface_List (N));
1817
1818       O_Decl :=
1819         Make_Object_Declaration (Loc,
1820           Defining_Identifier => O_Name,
1821           Object_Definition   => Make_Identifier (Loc,  Chars (T)));
1822
1823       Rewrite (N, T_Decl);
1824       Insert_After (N, O_Decl);
1825       Mark_Rewrite_Insertion (O_Decl);
1826
1827       --  Enter names of type and object before analysis, because the name of
1828       --  the object may be used in its own body.
1829
1830       Enter_Name (T);
1831       Set_Ekind (T, E_Protected_Type);
1832       Set_Etype (T, T);
1833
1834       Enter_Name (O_Name);
1835       Set_Ekind (O_Name, E_Variable);
1836       Set_Etype (O_Name, T);
1837
1838       --  Instead of calling Analyze on the new node, call the proper analysis
1839       --  procedure directly. Otherwise the node would be expanded twice, with
1840       --  disastrous result.
1841
1842       Analyze_Protected_Type_Declaration (N);
1843
1844       if Has_Aspects (N) then
1845          Analyze_Aspect_Specifications (N, Id);
1846       end if;
1847    end Analyze_Single_Protected_Declaration;
1848
1849    -------------------------------------
1850    -- Analyze_Single_Task_Declaration --
1851    -------------------------------------
1852
1853    procedure Analyze_Single_Task_Declaration (N : Node_Id) is
1854       Loc    : constant Source_Ptr := Sloc (N);
1855       Id     : constant Node_Id    := Defining_Identifier (N);
1856       T      : Entity_Id;
1857       T_Decl : Node_Id;
1858       O_Decl : Node_Id;
1859       O_Name : constant Entity_Id := Id;
1860
1861    begin
1862       Generate_Definition (Id);
1863       Tasking_Used := True;
1864
1865       --  The node is rewritten as a task type declaration, followed by an
1866       --  object declaration of that anonymous task type.
1867
1868       T :=
1869         Make_Defining_Identifier (Sloc (Id),
1870           New_External_Name (Chars (Id), Suffix => "TK"));
1871
1872       T_Decl :=
1873         Make_Task_Type_Declaration (Loc,
1874           Defining_Identifier => T,
1875           Task_Definition     => Relocate_Node (Task_Definition (N)),
1876           Interface_List      => Interface_List (N));
1877
1878       --  We use the original defining identifier of the single task in the
1879       --  generated object declaration, so that debugging information can
1880       --  be attached to it when compiling with -gnatD. The parent of the
1881       --  entity is the new object declaration. The single_task_declaration
1882       --  is not used further in semantics or code generation, but is scanned
1883       --  when generating debug information, and therefore needs the updated
1884       --  Sloc information for the entity (see Sprint). Aspect specifications
1885       --  are moved from the single task node to the object declaration node.
1886
1887       O_Decl :=
1888         Make_Object_Declaration (Loc,
1889           Defining_Identifier => O_Name,
1890           Object_Definition   => Make_Identifier (Loc, Chars (T)));
1891
1892       Rewrite (N, T_Decl);
1893       Insert_After (N, O_Decl);
1894       Mark_Rewrite_Insertion (O_Decl);
1895
1896       --  Enter names of type and object before analysis, because the name of
1897       --  the object may be used in its own body.
1898
1899       Enter_Name (T);
1900       Set_Ekind (T, E_Task_Type);
1901       Set_Etype (T, T);
1902
1903       Enter_Name (O_Name);
1904       Set_Ekind (O_Name, E_Variable);
1905       Set_Etype (O_Name, T);
1906
1907       --  Instead of calling Analyze on the new node, call the proper analysis
1908       --  procedure directly. Otherwise the node would be expanded twice, with
1909       --  disastrous result.
1910
1911       Analyze_Task_Type_Declaration (N);
1912
1913       if Has_Aspects (N) then
1914          Analyze_Aspect_Specifications (N, Id);
1915       end if;
1916    end Analyze_Single_Task_Declaration;
1917
1918    -----------------------
1919    -- Analyze_Task_Body --
1920    -----------------------
1921
1922    procedure Analyze_Task_Body (N : Node_Id) is
1923       Body_Id : constant Entity_Id := Defining_Identifier (N);
1924       Decls   : constant List_Id   := Declarations (N);
1925       HSS     : constant Node_Id   := Handled_Statement_Sequence (N);
1926       Last_E  : Entity_Id;
1927
1928       Spec_Id : Entity_Id;
1929       --  This is initially the entity of the task or task type involved, but
1930       --  is replaced by the task type always in the case of a single task
1931       --  declaration, since this is the proper scope to be used.
1932
1933       Ref_Id : Entity_Id;
1934       --  This is the entity of the task or task type, and is the entity used
1935       --  for cross-reference purposes (it differs from Spec_Id in the case of
1936       --  a single task, since Spec_Id is set to the task type)
1937
1938    begin
1939       Tasking_Used := True;
1940       Set_Ekind (Body_Id, E_Task_Body);
1941       Set_Scope (Body_Id, Current_Scope);
1942       Spec_Id := Find_Concurrent_Spec (Body_Id);
1943
1944       --  The spec is either a task type declaration, or a single task
1945       --  declaration for which we have created an anonymous type.
1946
1947       if Present (Spec_Id)
1948         and then Ekind (Spec_Id) = E_Task_Type
1949       then
1950          null;
1951
1952       elsif Present (Spec_Id)
1953         and then Ekind (Etype (Spec_Id)) = E_Task_Type
1954         and then not Comes_From_Source (Etype (Spec_Id))
1955       then
1956          null;
1957
1958       else
1959          Error_Msg_N ("missing specification for task body", Body_Id);
1960          return;
1961       end if;
1962
1963       if Has_Completion (Spec_Id)
1964         and then Present (Corresponding_Body (Parent (Spec_Id)))
1965       then
1966          if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1967             Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1968
1969          else
1970             Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1971          end if;
1972       end if;
1973
1974       Ref_Id := Spec_Id;
1975       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1976       Style.Check_Identifier (Body_Id, Spec_Id);
1977
1978       --  Deal with case of body of single task (anonymous type was created)
1979
1980       if Ekind (Spec_Id) = E_Variable then
1981          Spec_Id := Etype (Spec_Id);
1982       end if;
1983
1984       Push_Scope (Spec_Id);
1985       Set_Corresponding_Spec (N, Spec_Id);
1986       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1987       Set_Has_Completion (Spec_Id);
1988       Install_Declarations (Spec_Id);
1989       Last_E := Last_Entity (Spec_Id);
1990
1991       Analyze_Declarations (Decls);
1992       Inspect_Deferred_Constant_Completion (Decls);
1993
1994       --  For visibility purposes, all entities in the body are private. Set
1995       --  First_Private_Entity accordingly, if there was no private part in the
1996       --  protected declaration.
1997
1998       if No (First_Private_Entity (Spec_Id)) then
1999          if Present (Last_E) then
2000             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
2001          else
2002             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
2003          end if;
2004       end if;
2005
2006       --  Mark all handlers as not suitable for local raise optimization,
2007       --  since this optimization causes difficulties in a task context.
2008
2009       if Present (Exception_Handlers (HSS)) then
2010          declare
2011             Handlr : Node_Id;
2012          begin
2013             Handlr := First (Exception_Handlers (HSS));
2014             while Present (Handlr) loop
2015                Set_Local_Raise_Not_OK (Handlr);
2016                Next (Handlr);
2017             end loop;
2018          end;
2019       end if;
2020
2021       --  Now go ahead and complete analysis of the task body
2022
2023       Analyze (HSS);
2024       Check_Completion (Body_Id);
2025       Check_References (Body_Id);
2026       Check_References (Spec_Id);
2027
2028       --  Check for entries with no corresponding accept
2029
2030       declare
2031          Ent : Entity_Id;
2032
2033       begin
2034          Ent := First_Entity (Spec_Id);
2035          while Present (Ent) loop
2036             if Is_Entry (Ent)
2037               and then not Entry_Accepted (Ent)
2038               and then Comes_From_Source (Ent)
2039             then
2040                Error_Msg_NE ("no accept for entry &?", N, Ent);
2041             end if;
2042
2043             Next_Entity (Ent);
2044          end loop;
2045       end;
2046
2047       Process_End_Label (HSS, 't', Ref_Id);
2048       End_Scope;
2049    end Analyze_Task_Body;
2050
2051    -----------------------------
2052    -- Analyze_Task_Definition --
2053    -----------------------------
2054
2055    procedure Analyze_Task_Definition (N : Node_Id) is
2056       L : Entity_Id;
2057
2058    begin
2059       Tasking_Used := True;
2060       Check_SPARK_Restriction ("task definition is not allowed", N);
2061
2062       if Present (Visible_Declarations (N)) then
2063          Analyze_Declarations (Visible_Declarations (N));
2064       end if;
2065
2066       if Present (Private_Declarations (N)) then
2067          L := Last_Entity (Current_Scope);
2068          Analyze_Declarations (Private_Declarations (N));
2069
2070          if Present (L) then
2071             Set_First_Private_Entity
2072               (Current_Scope, Next_Entity (L));
2073          else
2074             Set_First_Private_Entity
2075               (Current_Scope, First_Entity (Current_Scope));
2076          end if;
2077       end if;
2078
2079       Check_Max_Entries (N, Max_Task_Entries);
2080       Process_End_Label (N, 'e', Current_Scope);
2081    end Analyze_Task_Definition;
2082
2083    -----------------------------------
2084    -- Analyze_Task_Type_Declaration --
2085    -----------------------------------
2086
2087    procedure Analyze_Task_Type_Declaration (N : Node_Id) is
2088       Def_Id : constant Entity_Id := Defining_Identifier (N);
2089       T      : Entity_Id;
2090
2091    begin
2092       Check_Restriction (No_Tasking, N);
2093       Tasking_Used := True;
2094       T := Find_Type_Name (N);
2095       Generate_Definition (T);
2096
2097       --  In the case of an incomplete type, use the full view, unless it's not
2098       --  present (as can occur for an incomplete view from a limited with).
2099       --  Initialize the Corresponding_Record_Type (which overlays the Private
2100       --  Dependents field of the incomplete view).
2101
2102       if Ekind (T) = E_Incomplete_Type then
2103          if Present (Full_View (T)) then
2104             T := Full_View (T);
2105             Set_Completion_Referenced (T);
2106
2107          else
2108             Set_Ekind (T, E_Task_Type);
2109             Set_Corresponding_Record_Type (T, Empty);
2110          end if;
2111       end if;
2112
2113       Set_Ekind              (T, E_Task_Type);
2114       Set_Is_First_Subtype   (T, True);
2115       Set_Has_Task           (T, True);
2116       Init_Size_Align        (T);
2117       Set_Etype              (T, T);
2118       Set_Has_Delayed_Freeze (T, True);
2119       Set_Stored_Constraint  (T, No_Elist);
2120       Push_Scope (T);
2121
2122       if Ada_Version >= Ada_2005 then
2123          Check_Interfaces (N, T);
2124       end if;
2125
2126       if Present (Discriminant_Specifications (N)) then
2127          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2128             Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
2129          end if;
2130
2131          if Has_Discriminants (T) then
2132
2133             --  Install discriminants. Also, verify conformance of
2134             --  discriminants of previous and current view. ???
2135
2136             Install_Declarations (T);
2137          else
2138             Process_Discriminants (N);
2139          end if;
2140       end if;
2141
2142       Set_Is_Constrained (T, not Has_Discriminants (T));
2143
2144       if Has_Aspects (N) then
2145          Analyze_Aspect_Specifications (N, Def_Id);
2146       end if;
2147
2148       if Present (Task_Definition (N)) then
2149          Analyze_Task_Definition (Task_Definition (N));
2150       end if;
2151
2152       --  In the case where the task type is declared at a nested level and the
2153       --  No_Task_Hierarchy restriction applies, issue a warning that objects
2154       --  of the type will violate the restriction.
2155
2156       if Restriction_Check_Required (No_Task_Hierarchy)
2157         and then not Is_Library_Level_Entity (T)
2158         and then Comes_From_Source (T)
2159       then
2160          Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
2161
2162          if Error_Msg_Sloc = No_Location then
2163             Error_Msg_N
2164               ("objects of this type will violate `No_Task_Hierarchy`?", N);
2165          else
2166             Error_Msg_N
2167               ("objects of this type will violate `No_Task_Hierarchy`?#", N);
2168          end if;
2169       end if;
2170
2171       End_Scope;
2172
2173       --  Case of a completion of a private declaration
2174
2175       if T /= Def_Id
2176         and then Is_Private_Type (Def_Id)
2177       then
2178          --  Deal with preelaborable initialization. Note that this processing
2179          --  is done by Process_Full_View, but as can be seen below, in this
2180          --  case the call to Process_Full_View is skipped if any serious
2181          --  errors have occurred, and we don't want to lose this check.
2182
2183          if Known_To_Have_Preelab_Init (Def_Id) then
2184             Set_Must_Have_Preelab_Init (T);
2185          end if;
2186
2187          --  Create corresponding record now, because some private dependents
2188          --  may be subtypes of the partial view.
2189
2190          --  Skip if errors are present, to prevent cascaded messages
2191
2192          if Serious_Errors_Detected = 0
2193
2194            --  Also skip if expander is not active
2195
2196            and then Full_Expander_Active
2197          then
2198             Expand_N_Task_Type_Declaration (N);
2199             Process_Full_View (N, T, Def_Id);
2200          end if;
2201       end if;
2202    end Analyze_Task_Type_Declaration;
2203
2204    -----------------------------------
2205    -- Analyze_Terminate_Alternative --
2206    -----------------------------------
2207
2208    procedure Analyze_Terminate_Alternative (N : Node_Id) is
2209    begin
2210       Tasking_Used := True;
2211
2212       if Present (Pragmas_Before (N)) then
2213          Analyze_List (Pragmas_Before (N));
2214       end if;
2215
2216       if Present (Condition (N)) then
2217          Analyze_And_Resolve (Condition (N), Any_Boolean);
2218       end if;
2219    end Analyze_Terminate_Alternative;
2220
2221    ------------------------------
2222    -- Analyze_Timed_Entry_Call --
2223    ------------------------------
2224
2225    procedure Analyze_Timed_Entry_Call (N : Node_Id) is
2226       Trigger        : constant Node_Id :=
2227                          Entry_Call_Statement (Entry_Call_Alternative (N));
2228       Is_Disp_Select : Boolean := False;
2229
2230    begin
2231       Tasking_Used := True;
2232       Check_SPARK_Restriction ("select statement is not allowed", N);
2233       Check_Restriction (No_Select_Statements, N);
2234
2235       --  Ada 2005 (AI-345): The trigger may be a dispatching call
2236
2237       if Ada_Version >= Ada_2005 then
2238          Analyze (Trigger);
2239          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
2240       end if;
2241
2242       --  Postpone the analysis of the statements till expansion. Analyze only
2243       --  if the expander is disabled in order to catch any semantic errors.
2244
2245       if Is_Disp_Select then
2246          if not Expander_Active then
2247             Analyze (Entry_Call_Alternative (N));
2248             Analyze (Delay_Alternative (N));
2249          end if;
2250
2251       --  Regular select analysis
2252
2253       else
2254          Analyze (Entry_Call_Alternative (N));
2255          Analyze (Delay_Alternative (N));
2256       end if;
2257    end Analyze_Timed_Entry_Call;
2258
2259    ------------------------------------
2260    -- Analyze_Triggering_Alternative --
2261    ------------------------------------
2262
2263    procedure Analyze_Triggering_Alternative (N : Node_Id) is
2264       Trigger : constant Node_Id := Triggering_Statement (N);
2265
2266    begin
2267       Tasking_Used := True;
2268
2269       if Present (Pragmas_Before (N)) then
2270          Analyze_List (Pragmas_Before (N));
2271       end if;
2272
2273       Analyze (Trigger);
2274
2275       if Comes_From_Source (Trigger)
2276         and then Nkind (Trigger) not in N_Delay_Statement
2277         and then Nkind (Trigger) /= N_Entry_Call_Statement
2278       then
2279          if Ada_Version < Ada_2005 then
2280             Error_Msg_N
2281              ("triggering statement must be delay or entry call", Trigger);
2282
2283          --  Ada 2005 (AI-345): If a procedure_call_statement is used for a
2284          --  procedure_or_entry_call, the procedure_name or procedure_prefix
2285          --  of the procedure_call_statement shall denote an entry renamed by a
2286          --  procedure, or (a view of) a primitive subprogram of a limited
2287          --  interface whose first parameter is a controlling parameter.
2288
2289          elsif Nkind (Trigger) = N_Procedure_Call_Statement
2290            and then not Is_Renamed_Entry (Entity (Name (Trigger)))
2291            and then not Is_Controlling_Limited_Procedure
2292                           (Entity (Name (Trigger)))
2293          then
2294             Error_Msg_N ("triggering statement must be delay, procedure " &
2295                          "or entry call", Trigger);
2296          end if;
2297       end if;
2298
2299       if Is_Non_Empty_List (Statements (N)) then
2300          Analyze_Statements (Statements (N));
2301       end if;
2302    end Analyze_Triggering_Alternative;
2303
2304    -----------------------
2305    -- Check_Max_Entries --
2306    -----------------------
2307
2308    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
2309       Ecount : Uint;
2310
2311       procedure Count (L : List_Id);
2312       --  Count entries in given declaration list
2313
2314       -----------
2315       -- Count --
2316       -----------
2317
2318       procedure Count (L : List_Id) is
2319          D : Node_Id;
2320
2321       begin
2322          if No (L) then
2323             return;
2324          end if;
2325
2326          D := First (L);
2327          while Present (D) loop
2328             if Nkind (D) = N_Entry_Declaration then
2329                declare
2330                   DSD : constant Node_Id :=
2331                           Discrete_Subtype_Definition (D);
2332
2333                begin
2334                   --  If not an entry family, then just one entry
2335
2336                   if No (DSD) then
2337                      Ecount := Ecount + 1;
2338
2339                   --  If entry family with static bounds, count entries
2340
2341                   elsif Is_OK_Static_Subtype (Etype (DSD)) then
2342                      declare
2343                         Lo : constant Uint :=
2344                                Expr_Value
2345                                  (Type_Low_Bound (Etype (DSD)));
2346                         Hi : constant Uint :=
2347                                Expr_Value
2348                                  (Type_High_Bound (Etype (DSD)));
2349
2350                      begin
2351                         if Hi >= Lo then
2352                            Ecount := Ecount + Hi - Lo + 1;
2353                         end if;
2354                      end;
2355
2356                   --  Entry family with non-static bounds
2357
2358                   else
2359                      --  Record an unknown count restriction, and if the
2360                      --  restriction is active, post a message or warning.
2361
2362                      Check_Restriction (R, D);
2363                   end if;
2364                end;
2365             end if;
2366
2367             Next (D);
2368          end loop;
2369       end Count;
2370
2371    --  Start of processing for Check_Max_Entries
2372
2373    begin
2374       Ecount := Uint_0;
2375       Count (Visible_Declarations (D));
2376       Count (Private_Declarations (D));
2377
2378       if Ecount > 0 then
2379          Check_Restriction (R, D, Ecount);
2380       end if;
2381    end Check_Max_Entries;
2382
2383    ----------------------
2384    -- Check_Interfaces --
2385    ----------------------
2386
2387    procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
2388       Iface     : Node_Id;
2389       Iface_Typ : Entity_Id;
2390
2391    begin
2392       pragma Assert
2393         (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
2394
2395       if Present (Interface_List (N)) then
2396          Set_Is_Tagged_Type (T);
2397
2398          Iface := First (Interface_List (N));
2399          while Present (Iface) loop
2400             Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
2401
2402             if not Is_Interface (Iface_Typ) then
2403                Error_Msg_NE
2404                  ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
2405
2406             else
2407                --  Ada 2005 (AI-251): "The declaration of a specific descendant
2408                --  of an interface type freezes the interface type" RM 13.14.
2409
2410                Freeze_Before (N, Etype (Iface));
2411
2412                if Nkind (N) = N_Protected_Type_Declaration then
2413
2414                   --  Ada 2005 (AI-345): Protected types can only implement
2415                   --  limited, synchronized, or protected interfaces (note that
2416                   --  the predicate Is_Limited_Interface includes synchronized
2417                   --  and protected interfaces).
2418
2419                   if Is_Task_Interface (Iface_Typ) then
2420                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
2421                        & "a task interface", Iface);
2422
2423                   elsif not Is_Limited_Interface (Iface_Typ) then
2424                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
2425                        & "a non-limited interface", Iface);
2426                   end if;
2427
2428                else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
2429
2430                   --  Ada 2005 (AI-345): Task types can only implement limited,
2431                   --  synchronized, or task interfaces (note that the predicate
2432                   --  Is_Limited_Interface includes synchronized and task
2433                   --  interfaces).
2434
2435                   if Is_Protected_Interface (Iface_Typ) then
2436                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2437                        "protected interface", Iface);
2438
2439                   elsif not Is_Limited_Interface (Iface_Typ) then
2440                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2441                        "non-limited interface", Iface);
2442                   end if;
2443                end if;
2444             end if;
2445
2446             Next (Iface);
2447          end loop;
2448       end if;
2449
2450       if not Has_Private_Declaration (T) then
2451          return;
2452       end if;
2453
2454       --  Additional checks on full-types associated with private type
2455       --  declarations. Search for the private type declaration.
2456
2457       declare
2458          Full_T_Ifaces : Elist_Id;
2459          Iface         : Node_Id;
2460          Priv_T        : Entity_Id;
2461          Priv_T_Ifaces : Elist_Id;
2462
2463       begin
2464          Priv_T := First_Entity (Scope (T));
2465          loop
2466             pragma Assert (Present (Priv_T));
2467
2468             if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
2469                exit when Full_View (Priv_T) = T;
2470             end if;
2471
2472             Next_Entity (Priv_T);
2473          end loop;
2474
2475          --  In case of synchronized types covering interfaces the private type
2476          --  declaration must be limited.
2477
2478          if Present (Interface_List (N))
2479            and then not Is_Limited_Type (Priv_T)
2480          then
2481             Error_Msg_Sloc := Sloc (Priv_T);
2482             Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
2483                          "private type#", T);
2484          end if;
2485
2486          --  RM 7.3 (7.1/2): If the full view has a partial view that is
2487          --  tagged then check RM 7.3 subsidiary rules.
2488
2489          if Is_Tagged_Type (Priv_T)
2490            and then not Error_Posted (N)
2491          then
2492             --  RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2493             --  type if and only if the full type is a synchronized tagged type
2494
2495             if Is_Synchronized_Tagged_Type (Priv_T)
2496               and then not Is_Synchronized_Tagged_Type (T)
2497             then
2498                Error_Msg_N
2499                  ("(Ada 2005) full view must be a synchronized tagged " &
2500                   "type (RM 7.3 (7.2/2))", Priv_T);
2501
2502             elsif Is_Synchronized_Tagged_Type (T)
2503               and then not Is_Synchronized_Tagged_Type (Priv_T)
2504             then
2505                Error_Msg_N
2506                  ("(Ada 2005) partial view must be a synchronized tagged " &
2507                   "type (RM 7.3 (7.2/2))", T);
2508             end if;
2509
2510             --  RM 7.3 (7.3/2): The partial view shall be a descendant of an
2511             --  interface type if and only if the full type is descendant of
2512             --  the interface type.
2513
2514             if Present (Interface_List (N))
2515               or else (Is_Tagged_Type (Priv_T)
2516                          and then Has_Interfaces
2517                                    (Priv_T, Use_Full_View => False))
2518             then
2519                if Is_Tagged_Type (Priv_T) then
2520                   Collect_Interfaces
2521                     (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
2522                end if;
2523
2524                if Is_Tagged_Type (T) then
2525                   Collect_Interfaces (T, Full_T_Ifaces);
2526                end if;
2527
2528                Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
2529
2530                if Present (Iface) then
2531                   Error_Msg_NE
2532                     ("interface & not implemented by full type " &
2533                      "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
2534                end if;
2535
2536                Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
2537
2538                if Present (Iface) then
2539                   Error_Msg_NE
2540                     ("interface & not implemented by partial " &
2541                      "view (RM-2005 7.3 (7.3/2))", T, Iface);
2542                end if;
2543             end if;
2544          end if;
2545       end;
2546    end Check_Interfaces;
2547
2548    --------------------------------
2549    -- Check_Triggering_Statement --
2550    --------------------------------
2551
2552    procedure Check_Triggering_Statement
2553      (Trigger        : Node_Id;
2554       Error_Node     : Node_Id;
2555       Is_Dispatching : out Boolean)
2556    is
2557       Param : Node_Id;
2558
2559    begin
2560       Is_Dispatching := False;
2561
2562       --  It is not possible to have a dispatching trigger if we are not in
2563       --  Ada 2005 mode.
2564
2565       if Ada_Version >= Ada_2005
2566         and then Nkind (Trigger) = N_Procedure_Call_Statement
2567         and then Present (Parameter_Associations (Trigger))
2568       then
2569          Param := First (Parameter_Associations (Trigger));
2570
2571          if Is_Controlling_Actual (Param)
2572            and then Is_Interface (Etype (Param))
2573          then
2574             if Is_Limited_Record (Etype (Param)) then
2575                Is_Dispatching := True;
2576             else
2577                Error_Msg_N
2578                  ("dispatching operation of limited or synchronized " &
2579                   "interface required (RM 9.7.2(3))!", Error_Node);
2580             end if;
2581          end if;
2582       end if;
2583    end Check_Triggering_Statement;
2584
2585    --------------------------
2586    -- Find_Concurrent_Spec --
2587    --------------------------
2588
2589    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2590       Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2591
2592    begin
2593       --  The type may have been given by an incomplete type declaration.
2594       --  Find full view now.
2595
2596       if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2597          Spec_Id := Full_View (Spec_Id);
2598       end if;
2599
2600       return Spec_Id;
2601    end Find_Concurrent_Spec;
2602
2603    --------------------------
2604    -- Install_Declarations --
2605    --------------------------
2606
2607    procedure Install_Declarations (Spec : Entity_Id) is
2608       E    : Entity_Id;
2609       Prev : Entity_Id;
2610    begin
2611       E := First_Entity (Spec);
2612       while Present (E) loop
2613          Prev := Current_Entity (E);
2614          Set_Current_Entity (E);
2615          Set_Is_Immediately_Visible (E);
2616          Set_Homonym (E, Prev);
2617          Next_Entity (E);
2618       end loop;
2619    end Install_Declarations;
2620
2621 end Sem_Ch9;