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