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