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