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