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