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