gcc/ada/sem_ch9.adb

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