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