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