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