gcc/ada/sem_ch9.adb

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