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