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