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