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-2012, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Exp_Ch9;  use Exp_Ch9;
  33 with Elists;   use Elists;
  34 with Freeze;   use Freeze;
  35 with Layout;   use Layout;
  36 with Lib.Xref; use Lib.Xref;
  37 with Namet;    use Namet;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Restrict; use Restrict;
  42 with Rident;   use Rident;
  43 with Rtsfind;  use Rtsfind;
  44 with Sem;      use Sem;
  45 with Sem_Aux;  use Sem_Aux;
  46 with Sem_Ch3;  use Sem_Ch3;
  47 with Sem_Ch5;  use Sem_Ch5;
  48 with Sem_Ch6;  use Sem_Ch6;
  49 with Sem_Ch8;  use Sem_Ch8;
  50 with Sem_Ch13; use Sem_Ch13;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Type; use Sem_Type;
  54 with Sem_Util; use Sem_Util;
  55 with Sem_Warn; use Sem_Warn;
  56 with Snames;   use Snames;
  57 with Stand;    use Stand;
  58 with Sinfo;    use Sinfo;
  59 with Style;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Uintp;    use Uintp;
  63
  64 package body Sem_Ch9 is
  65
  66    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    function Allows_Lock_Free_Implementation
  71      (N               : Node_Id;
  72       Lock_Free_Given : Boolean := False) return Boolean;
  73    --  This routine returns True iff N satisfies the following list of lock-
  74    --  free restrictions for protected type declaration and protected body:
  75    --
  76    --    1) Protected type declaration
  77    --         May not contain entries
  78    --         Protected subprogram declarations may not have non-elementary
  79    --           parameters.
  80    --
  81    --    2) Protected Body
  82    --         Each protected subprogram body within N must satisfy:
  83    --            May reference only one protected component
  84    --            May not reference non-constant entities outside the protected
  85    --              subprogram scope.
  86    --            May not contain address representation items, allocators and
  87    --              quantified expressions.
  88    --            May not contain delay, goto, loop and procedure call
  89    --              statements.
  90    --            May not contain exported and imported entities
  91    --            May not dereference access values
  92    --            Function calls and attribute references must be static
  93    --
  94    --  If Lock_Free_Given is True, an error message is issued when False is
  95    --  returned.
  96
  97    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
  98    --  Given either a protected definition or a task definition in D, check
  99    --  the corresponding restriction parameter identifier R, and if it is set,
 100    --  count the entries (checking the static requirement), and compare with
 101    --  the given maximum.
 102
 103    procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
 104    --  N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
 105    --  Complete decoration of T and check legality of the covered interfaces.
 106
 107    procedure Check_Triggering_Statement
 108      (Trigger        : Node_Id;
 109       Error_Node     : Node_Id;
 110       Is_Dispatching : out Boolean);
 111    --  Examine the triggering statement of a select statement, conditional or
 112    --  timed entry call. If Trigger is a dispatching call, return its status
 113    --  in Is_Dispatching and check whether the primitive belongs to a limited
 114    --  interface. If it does not, emit an error at Error_Node.
 115
 116    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
 117    --  Find entity in corresponding task or protected declaration. Use full
 118    --  view if first declaration was for an incomplete type.
 119
 120    -------------------------------------
 121    -- Allows_Lock_Free_Implementation --
 122    -------------------------------------
 123
 124    function Allows_Lock_Free_Implementation
 125      (N               : Node_Id;
 126       Lock_Free_Given : Boolean := False) return Boolean
 127    is
 128       Errors_Count : Nat;
 129       --  Errors_Count is a count of errors detected by the compiler so far
 130       --  when Lock_Free_Given is True.
 131
 132    begin
 133       pragma Assert (Nkind_In (N, N_Protected_Type_Declaration,
 134                                   N_Protected_Body));
 135
 136       --  The lock-free implementation is currently enabled through a debug
 137       --  flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
 138       --  lock-free implementation. In that case, the debug flag is not needed.
 139
 140       if not Lock_Free_Given and then not Debug_Flag_9 then
 141          return False;
 142       end if;
 143
 144       --  Get the number of errors detected by the compiler so far
 145
 146       if Lock_Free_Given then
 147          Errors_Count := Serious_Errors_Detected;
 148       end if;
 149
 150       --  Protected type declaration case
 151
 152       if Nkind (N) = N_Protected_Type_Declaration then
 153          declare
 154             Pdef       : constant Node_Id := Protected_Definition (N);
 155             Priv_Decls : constant List_Id := Private_Declarations (Pdef);
 156             Vis_Decls  : constant List_Id := Visible_Declarations (Pdef);
 157             Decl       : Node_Id;
 158
 159          begin
 160             --  Examine the visible and the private declarations
 161
 162             Decl := First (Vis_Decls);
 163             while Present (Decl) loop
 164
 165                --  Entries and entry families are not allowed by the lock-free
 166                --  restrictions.
 167
 168                if Nkind (Decl) = N_Entry_Declaration then
 169                   if Lock_Free_Given then
 170                      Error_Msg_N
 171                        ("entry not allowed when Lock_Free given", Decl);
 172                   else
 173                      return False;
 174                   end if;
 175
 176                --  Non-elementary parameters in protected procedure are not
 177                --  allowed by the lock-free restrictions.
 178
 179                elsif Nkind (Decl) = N_Subprogram_Declaration
 180                  and then
 181                    Nkind (Specification (Decl)) = N_Procedure_Specification
 182                  and then
 183                    Present (Parameter_Specifications (Specification (Decl)))
 184                then
 185                   declare
 186                      Par_Specs : constant List_Id   :=
 187                                    Parameter_Specifications
 188                                      (Specification (Decl));
 189
 190                      Par : Node_Id;
 191
 192                   begin
 193                      Par := First (Par_Specs);
 194                      while Present (Par) loop
 195                         if not Is_Elementary_Type
 196                                  (Etype (Defining_Identifier (Par)))
 197                         then
 198                            if Lock_Free_Given then
 199                               Error_Msg_NE
 200                                 ("non-elementary parameter& not allowed "
 201                                  & "when Lock_Free given",
 202                                  Par, Defining_Identifier (Par));
 203                            else
 204                               return False;
 205                            end if;
 206                         end if;
 207
 208                         Next (Par);
 209                      end loop;
 210                   end;
 211                end if;
 212
 213                --  Examine private declarations after visible declarations
 214
 215                if No (Next (Decl))
 216                  and then List_Containing (Decl) = Vis_Decls
 217                then
 218                   Decl := First (Priv_Decls);
 219                else
 220                   Next (Decl);
 221                end if;
 222             end loop;
 223          end;
 224
 225       --  Protected body case
 226
 227       else
 228          Protected_Body_Case : declare
 229             Decls         : constant List_Id   := Declarations (N);
 230             Pid           : constant Entity_Id := Corresponding_Spec (N);
 231             Prot_Typ_Decl : constant Node_Id   := Parent (Pid);
 232             Prot_Def      : constant Node_Id   :=
 233                               Protected_Definition (Prot_Typ_Decl);
 234             Priv_Decls    : constant List_Id   :=
 235                               Private_Declarations (Prot_Def);
 236             Decl          : Node_Id;
 237
 238             function Satisfies_Lock_Free_Requirements
 239               (Sub_Body : Node_Id) return Boolean;
 240             --  Return True if protected subprogram body Sub_Body satisfies all
 241             --  requirements of a lock-free implementation.
 242
 243             --------------------------------------
 244             -- Satisfies_Lock_Free_Requirements --
 245             --------------------------------------
 246
 247             function Satisfies_Lock_Free_Requirements
 248               (Sub_Body : Node_Id) return Boolean
 249             is
 250                Is_Procedure : constant Boolean    :=
 251                                 Ekind (Corresponding_Spec (Sub_Body)) =
 252                                   E_Procedure;
 253                --  Indicates if Sub_Body is a procedure body
 254
 255                Comp : Entity_Id := Empty;
 256                --  Track the current component which the body references
 257
 258                Errors_Count : Nat;
 259                --  Errors_Count is a count of errors detected by the compiler
 260                --  so far when Lock_Free_Given is True.
 261
 262                function Check_Node (N : Node_Id) return Traverse_Result;
 263                --  Check that node N meets the lock free restrictions
 264
 265                ----------------
 266                -- Check_Node --
 267                ----------------
 268
 269                function Check_Node (N : Node_Id) return Traverse_Result is
 270                   Kind : constant Node_Kind := Nkind (N);
 271
 272                   --  The following function belongs in sem_eval ???
 273
 274                   function Is_Static_Function (Attr : Node_Id) return Boolean;
 275                   --  Given an attribute reference node Attr, return True if
 276                   --  Attr denotes a static function according to the rules in
 277                   --  (RM 4.9 (22)).
 278
 279                   ------------------------
 280                   -- Is_Static_Function --
 281                   ------------------------
 282
 283                   function Is_Static_Function
 284                     (Attr : Node_Id) return Boolean
 285                   is
 286                      Para : Node_Id;
 287
 288                   begin
 289                      pragma Assert (Nkind (Attr) = N_Attribute_Reference);
 290
 291                      case Attribute_Name (Attr) is
 292                         when Name_Min             |
 293                              Name_Max             |
 294                              Name_Pred            |
 295                              Name_Succ            |
 296                              Name_Value           |
 297                              Name_Wide_Value      |
 298                              Name_Wide_Wide_Value =>
 299
 300                            --  A language-defined attribute denotes a static
 301                            --  function if the prefix denotes a static scalar
 302                            --  subtype, and if the parameter and result types
 303                            --  are scalar (RM 4.9 (22)).
 304
 305                            if Is_Scalar_Type (Etype (Attr))
 306                              and then Is_Scalar_Type (Etype (Prefix (Attr)))
 307                              and then Is_Static_Subtype (Etype (Prefix (Attr)))
 308                            then
 309                               Para := First (Expressions (Attr));
 310
 311                               while Present (Para) loop
 312                                  if not Is_Scalar_Type (Etype (Para)) then
 313                                     return False;
 314                                  end if;
 315
 316                                  Next (Para);
 317                               end loop;
 318
 319                               return True;
 320
 321                            else
 322                               return False;
 323                            end if;
 324
 325                         when others => return False;
 326                      end case;
 327                   end Is_Static_Function;
 328
 329                --  Start of processing for Check_Node
 330
 331                begin
 332                   if Is_Procedure then
 333                      --  Allocators restricted
 334
 335                      if Kind = N_Allocator then
 336                         if Lock_Free_Given then
 337                            Error_Msg_N ("allocator not allowed", N);
 338                            return Skip;
 339                         end if;
 340
 341                         return Abandon;
 342
 343                      --  Aspects Address, Export and Import restricted
 344
 345                      elsif Kind = N_Aspect_Specification then
 346                         declare
 347                            Asp_Name : constant Name_Id   :=
 348                                         Chars (Identifier (N));
 349                            Asp_Id   : constant Aspect_Id :=
 350                                         Get_Aspect_Id (Asp_Name);
 351
 352                         begin
 353                            if Asp_Id = Aspect_Address or else
 354                               Asp_Id = Aspect_Export  or else
 355                               Asp_Id = Aspect_Import
 356                            then
 357                               Error_Msg_Name_1 := Asp_Name;
 358
 359                               if Lock_Free_Given then
 360                                  Error_Msg_N ("aspect% not allowed", N);
 361                                  return Skip;
 362                               end if;
 363
 364                               return Abandon;
 365                            end if;
 366                         end;
 367
 368                      --  Address attribute definition clause restricted
 369
 370                      elsif Kind = N_Attribute_Definition_Clause
 371                        and then Get_Attribute_Id (Chars (N)) =
 372                                   Attribute_Address
 373                      then
 374                         Error_Msg_Name_1 := Chars (N);
 375
 376                         if Lock_Free_Given then
 377                            if From_Aspect_Specification (N) then
 378                               Error_Msg_N ("aspect% not allowed", N);
 379                            else
 380                               Error_Msg_N ("% clause not allowed", N);
 381                            end if;
 382
 383                            return Skip;
 384                         end if;
 385
 386                         return Abandon;
 387
 388                      --  Non-static Attribute references that don't denote a
 389                      --  static function restricted.
 390
 391                      elsif Kind = N_Attribute_Reference
 392                        and then not Is_Static_Expression (N)
 393                        and then not Is_Static_Function (N)
 394                      then
 395                         if Lock_Free_Given then
 396                            Error_Msg_N
 397                              ("non-static attribute reference not allowed", N);
 398                            return Skip;
 399                         end if;
 400
 401                         return Abandon;
 402
 403                      --  Delay statements restricted
 404
 405                      elsif Kind in N_Delay_Statement then
 406                         if Lock_Free_Given then
 407                            Error_Msg_N ("delay not allowed", N);
 408                            return Skip;
 409                         end if;
 410
 411                         return Abandon;
 412
 413                      --  Dereferences of access values restricted
 414
 415                      elsif Kind = N_Explicit_Dereference
 416                        or else (Kind = N_Selected_Component
 417                                  and then Is_Access_Type (Etype (Prefix (N))))
 418                      then
 419                         if Lock_Free_Given then
 420                            Error_Msg_N
 421                              ("dereference of access value not allowed", N);
 422                            return Skip;
 423                         end if;
 424
 425                         return Abandon;
 426
 427                      --  Non-static function calls restricted
 428
 429                      elsif Kind = N_Function_Call
 430                        and then not Is_Static_Expression (N)
 431                      then
 432                         if Lock_Free_Given then
 433                            Error_Msg_N
 434                              ("non-static function call not allowed", N);
 435                            return Skip;
 436                         end if;
 437
 438                         return Abandon;
 439
 440                      --  Goto statements restricted
 441
 442                      elsif Kind = N_Goto_Statement then
 443                         if Lock_Free_Given then
 444                            Error_Msg_N ("goto statement not allowed", N);
 445                            return Skip;
 446                         end if;
 447
 448                         return Abandon;
 449
 450                      --  References
 451
 452                      elsif Kind = N_Identifier
 453                        and then Present (Entity (N))
 454                      then
 455                         declare
 456                            Id     : constant Entity_Id := Entity (N);
 457                            Sub_Id : constant Entity_Id :=
 458                                       Corresponding_Spec (Sub_Body);
 459
 460                         begin
 461                            --  Prohibit references to non-constant entities
 462                            --  outside the protected subprogram scope.
 463
 464                            if Ekind (Id) in Assignable_Kind
 465                              and then not
 466                                Scope_Within_Or_Same (Scope (Id), Sub_Id)
 467                              and then not
 468                                Scope_Within_Or_Same
 469                                  (Scope (Id),
 470                                   Protected_Body_Subprogram (Sub_Id))
 471                            then
 472                               if Lock_Free_Given then
 473                                  Error_Msg_NE
 474                                    ("reference to global variable& not " &
 475                                     "allowed", N, Id);
 476                                  return Skip;
 477                               end if;
 478
 479                               return Abandon;
 480                            end if;
 481                         end;
 482
 483                      --  Loop statements restricted
 484
 485                      elsif Kind = N_Loop_Statement then
 486                         if Lock_Free_Given then
 487                            Error_Msg_N ("loop not allowed", N);
 488                            return Skip;
 489                         end if;
 490
 491                         return Abandon;
 492
 493                      --  Pragmas Export and Import restricted
 494
 495                      elsif Kind = N_Pragma then
 496                         declare
 497                            Prag_Name : constant Name_Id   := Pragma_Name (N);
 498                            Prag_Id   : constant Pragma_Id :=
 499                                          Get_Pragma_Id (Prag_Name);
 500
 501                         begin
 502                            if Prag_Id = Pragma_Export
 503                              or else Prag_Id = Pragma_Import
 504                            then
 505                               Error_Msg_Name_1 := Prag_Name;
 506
 507                               if Lock_Free_Given then
 508                                  if From_Aspect_Specification (N) then
 509                                     Error_Msg_N ("aspect% not allowed", N);
 510                                  else
 511                                     Error_Msg_N ("pragma% not allowed", N);
 512                                  end if;
 513
 514                                  return Skip;
 515                               end if;
 516
 517                               return Abandon;
 518                            end if;
 519                         end;
 520
 521                      --  Procedure call statements restricted
 522
 523                      elsif Kind = N_Procedure_Call_Statement then
 524                         if Lock_Free_Given then
 525                            Error_Msg_N ("procedure call not allowed", N);
 526                            return Skip;
 527                         end if;
 528
 529                         return Abandon;
 530
 531                      --  Quantified expression restricted. Note that we have
 532                      --  to check the original node as well, since at this
 533                      --  stage, it may have been rewritten.
 534
 535                      elsif Kind = N_Quantified_Expression
 536                        or else
 537                          Nkind (Original_Node (N)) = N_Quantified_Expression
 538                      then
 539                         if Lock_Free_Given then
 540                            Error_Msg_N
 541                              ("quantified expression not allowed", N);
 542                            return Skip;
 543                         end if;
 544
 545                         return Abandon;
 546                      end if;
 547                   end if;
 548
 549                   --  A protected subprogram (function or procedure) may
 550                   --  reference only one component of the protected type, plus
 551                   --  the type of the component must support atomic operation.
 552
 553                   if Kind = N_Identifier
 554                     and then Present (Entity (N))
 555                   then
 556                      declare
 557                         Id        : constant Entity_Id := Entity (N);
 558                         Comp_Decl : Node_Id;
 559                         Comp_Id   : Entity_Id := Empty;
 560                         Comp_Type : Entity_Id;
 561
 562                      begin
 563                         if Ekind (Id) = E_Component then
 564                            Comp_Id := Id;
 565
 566                         elsif Ekind_In (Id, E_Constant, E_Variable)
 567                           and then Present (Prival_Link (Id))
 568                         then
 569                            Comp_Id := Prival_Link (Id);
 570                         end if;
 571
 572                         if Present (Comp_Id) then
 573                            Comp_Decl := Parent (Comp_Id);
 574                            Comp_Type := Etype (Comp_Id);
 575
 576                            if Nkind (Comp_Decl) = N_Component_Declaration
 577                              and then Is_List_Member (Comp_Decl)
 578                              and then List_Containing (Comp_Decl) = Priv_Decls
 579                            then
 580                               --  Skip generic types since, in that case, we
 581                               --  will not build a body anyway (in the generic
 582                               --  template), and the size in the template may
 583                               --  have a fake value.
 584
 585                               if not Is_Generic_Type (Comp_Type) then
 586
 587                                  --  Make sure the protected component type has
 588                                  --  size and alignment fields set at this
 589                                  --  point whenever this is possible.
 590
 591                                  Layout_Type (Comp_Type);
 592
 593                                  if not
 594                                    Support_Atomic_Primitives (Comp_Type)
 595                                  then
 596                                     if Lock_Free_Given then
 597                                        Error_Msg_NE
 598                                          ("type of& must support atomic " &
 599                                           "operations",
 600                                           N, Comp_Id);
 601                                        return Skip;
 602                                     end if;
 603
 604                                     return Abandon;
 605                                  end if;
 606                               end if;
 607
 608                               --  Check if another protected component has
 609                               --  already been accessed by the subprogram body.
 610
 611                               if No (Comp) then
 612                                  Comp := Comp_Id;
 613
 614                               elsif Comp /= Comp_Id then
 615                                  if Lock_Free_Given then
 616                                     Error_Msg_N
 617                                       ("only one protected component allowed",
 618                                        N);
 619                                     return Skip;
 620                                  end if;
 621
 622                                  return Abandon;
 623                               end if;
 624                            end if;
 625                         end if;
 626                      end;
 627                   end if;
 628
 629                   return OK;
 630                end Check_Node;
 631
 632                function Check_All_Nodes is new Traverse_Func (Check_Node);
 633
 634             --  Start of processing for Satisfies_Lock_Free_Requirements
 635
 636             begin
 637                --  Get the number of errors detected by the compiler so far
 638
 639                if Lock_Free_Given then
 640                   Errors_Count := Serious_Errors_Detected;
 641                end if;
 642
 643                if Check_All_Nodes (Sub_Body) = OK
 644                  and then (not Lock_Free_Given
 645                             or else Errors_Count = Serious_Errors_Detected)
 646                then
 647                   --  Establish a relation between the subprogram body and the
 648                   --  unique protected component it references.
 649
 650                   if Present (Comp) then
 651                      Lock_Free_Subprogram_Table.Append
 652                        (Lock_Free_Subprogram'(Sub_Body, Comp));
 653                   end if;
 654
 655                   return True;
 656                else
 657                   return False;
 658                end if;
 659             end Satisfies_Lock_Free_Requirements;
 660
 661          --  Start of processing for Protected_Body_Case
 662
 663          begin
 664             Decl := First (Decls);
 665             while Present (Decl) loop
 666                if Nkind (Decl) = N_Subprogram_Body
 667                  and then not Satisfies_Lock_Free_Requirements (Decl)
 668                then
 669                   if Lock_Free_Given then
 670                      Error_Msg_N
 671                        ("illegal body when Lock_Free given", Decl);
 672                   else
 673                      return False;
 674                   end if;
 675                end if;
 676
 677                Next (Decl);
 678             end loop;
 679          end Protected_Body_Case;
 680       end if;
 681
 682       --  When Lock_Free is given, check if no error has been detected during
 683       --  the process.
 684
 685       if Lock_Free_Given
 686         and then Errors_Count /= Serious_Errors_Detected
 687       then
 688          return False;
 689       end if;
 690
 691       return True;
 692    end Allows_Lock_Free_Implementation;
 693
 694    -----------------------------
 695    -- Analyze_Abort_Statement --
 696    -----------------------------
 697
 698    procedure Analyze_Abort_Statement (N : Node_Id) is
 699       T_Name : Node_Id;
 700
 701    begin
 702       Tasking_Used := True;
 703       Check_SPARK_Restriction ("abort statement is not allowed", N);
 704
 705       T_Name := First (Names (N));
 706       while Present (T_Name) loop
 707          Analyze (T_Name);
 708
 709          if Is_Task_Type (Etype (T_Name))
 710            or else (Ada_Version >= Ada_2005
 711                       and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
 712                       and then Is_Interface (Etype (T_Name))
 713                       and then Is_Task_Interface (Etype (T_Name)))
 714          then
 715             Resolve (T_Name);
 716          else
 717             if Ada_Version >= Ada_2005 then
 718                Error_Msg_N ("expect task name or task interface class-wide "
 719                             & "object for ABORT", T_Name);
 720             else
 721                Error_Msg_N ("expect task name for ABORT", T_Name);
 722             end if;
 723
 724             return;
 725          end if;
 726
 727          Next (T_Name);
 728       end loop;
 729
 730       Check_Restriction (No_Abort_Statements, N);
 731       Check_Potentially_Blocking_Operation (N);
 732    end Analyze_Abort_Statement;
 733
 734    --------------------------------
 735    -- Analyze_Accept_Alternative --
 736    --------------------------------
 737
 738    procedure Analyze_Accept_Alternative (N : Node_Id) is
 739    begin
 740       Tasking_Used := True;
 741
 742       if Present (Pragmas_Before (N)) then
 743          Analyze_List (Pragmas_Before (N));
 744       end if;
 745
 746       if Present (Condition (N)) then
 747          Analyze_And_Resolve (Condition (N), Any_Boolean);
 748       end if;
 749
 750       Analyze (Accept_Statement (N));
 751
 752       if Is_Non_Empty_List (Statements (N)) then
 753          Analyze_Statements (Statements (N));
 754       end if;
 755    end Analyze_Accept_Alternative;
 756
 757    ------------------------------
 758    -- Analyze_Accept_Statement --
 759    ------------------------------
 760
 761    procedure Analyze_Accept_Statement (N : Node_Id) is
 762       Nam       : constant Entity_Id := Entry_Direct_Name (N);
 763       Formals   : constant List_Id   := Parameter_Specifications (N);
 764       Index     : constant Node_Id   := Entry_Index (N);
 765       Stats     : constant Node_Id   := Handled_Statement_Sequence (N);
 766       Accept_Id : Entity_Id;
 767       Entry_Nam : Entity_Id;
 768       E         : Entity_Id;
 769       Kind      : Entity_Kind;
 770       Task_Nam  : Entity_Id;
 771
 772    begin
 773       Tasking_Used := True;
 774       Check_SPARK_Restriction ("accept statement is not allowed", N);
 775
 776       --  Entry name is initialized to Any_Id. It should get reset to the
 777       --  matching entry entity. An error is signalled if it is not reset.
 778
 779       Entry_Nam := Any_Id;
 780
 781       for J in reverse 0 .. Scope_Stack.Last loop
 782          Task_Nam := Scope_Stack.Table (J).Entity;
 783          exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
 784          Kind :=  Ekind (Task_Nam);
 785
 786          if Kind /= E_Block and then Kind /= E_Loop
 787            and then not Is_Entry (Task_Nam)
 788          then
 789             Error_Msg_N ("enclosing body of accept must be a task", N);
 790             return;
 791          end if;
 792       end loop;
 793
 794       if Ekind (Etype (Task_Nam)) /= E_Task_Type then
 795          Error_Msg_N ("invalid context for accept statement",  N);
 796          return;
 797       end if;
 798
 799       --  In order to process the parameters, we create a defining identifier
 800       --  that can be used as the name of the scope. The name of the accept
 801       --  statement itself is not a defining identifier, and we cannot use
 802       --  its name directly because the task may have any number of accept
 803       --  statements for the same entry.
 804
 805       if Present (Index) then
 806          Accept_Id := New_Internal_Entity
 807            (E_Entry_Family, Current_Scope, Sloc (N), 'E');
 808       else
 809          Accept_Id := New_Internal_Entity
 810            (E_Entry, Current_Scope, Sloc (N), 'E');
 811       end if;
 812
 813       Set_Etype          (Accept_Id, Standard_Void_Type);
 814       Set_Accept_Address (Accept_Id, New_Elmt_List);
 815
 816       if Present (Formals) then
 817          Push_Scope (Accept_Id);
 818          Process_Formals (Formals, N);
 819          Create_Extra_Formals (Accept_Id);
 820          End_Scope;
 821       end if;
 822
 823       --  We set the default expressions processed flag because we don't need
 824       --  default expression functions. This is really more like body entity
 825       --  than a spec entity anyway.
 826
 827       Set_Default_Expressions_Processed (Accept_Id);
 828
 829       E := First_Entity (Etype (Task_Nam));
 830       while Present (E) loop
 831          if Chars (E) = Chars (Nam)
 832            and then (Ekind (E) = Ekind (Accept_Id))
 833            and then Type_Conformant (Accept_Id, E)
 834          then
 835             Entry_Nam := E;
 836             exit;
 837          end if;
 838
 839          Next_Entity (E);
 840       end loop;
 841
 842       if Entry_Nam = Any_Id then
 843          Error_Msg_N ("no entry declaration matches accept statement",  N);
 844          return;
 845       else
 846          Set_Entity (Nam, Entry_Nam);
 847          Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
 848          Style.Check_Identifier (Nam, Entry_Nam);
 849       end if;
 850
 851       --  Verify that the entry is not hidden by a procedure declared in the
 852       --  current block (pathological but possible).
 853
 854       if Current_Scope /= Task_Nam then
 855          declare
 856             E1 : Entity_Id;
 857
 858          begin
 859             E1 := First_Entity (Current_Scope);
 860             while Present (E1) loop
 861                if Ekind (E1) = E_Procedure
 862                  and then Chars (E1) = Chars (Entry_Nam)
 863                  and then Type_Conformant (E1, Entry_Nam)
 864                then
 865                   Error_Msg_N ("entry name is not visible", N);
 866                end if;
 867
 868                Next_Entity (E1);
 869             end loop;
 870          end;
 871       end if;
 872
 873       Set_Convention (Accept_Id, Convention (Entry_Nam));
 874       Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
 875
 876       for J in reverse 0 .. Scope_Stack.Last loop
 877          exit when Task_Nam = Scope_Stack.Table (J).Entity;
 878
 879          if Entry_Nam = Scope_Stack.Table (J).Entity then
 880             Error_Msg_N ("duplicate accept statement for same entry", N);
 881          end if;
 882       end loop;
 883
 884       declare
 885          P : Node_Id := N;
 886       begin
 887          loop
 888             P := Parent (P);
 889             case Nkind (P) is
 890                when N_Task_Body | N_Compilation_Unit =>
 891                   exit;
 892                when N_Asynchronous_Select =>
 893                   Error_Msg_N ("accept statements are not allowed within" &
 894                                " an asynchronous select inner" &
 895                                " to the enclosing task body", N);
 896                   exit;
 897                when others =>
 898                   null;
 899             end case;
 900          end loop;
 901       end;
 902
 903       if Ekind (E) = E_Entry_Family then
 904          if No (Index) then
 905             Error_Msg_N ("missing entry index in accept for entry family", N);
 906          else
 907             Analyze_And_Resolve (Index, Entry_Index_Type (E));
 908             Apply_Range_Check (Index, Entry_Index_Type (E));
 909          end if;
 910
 911       elsif Present (Index) then
 912          Error_Msg_N ("invalid entry index in accept for simple entry", N);
 913       end if;
 914
 915       --  If label declarations present, analyze them. They are declared in the
 916       --  enclosing task, but their enclosing scope is the entry itself, so
 917       --  that goto's to the label are recognized as local to the accept.
 918
 919       if Present (Declarations (N)) then
 920          declare
 921             Decl : Node_Id;
 922             Id   : Entity_Id;
 923
 924          begin
 925             Decl := First (Declarations (N));
 926             while Present (Decl) loop
 927                Analyze (Decl);
 928
 929                pragma Assert
 930                  (Nkind (Decl) = N_Implicit_Label_Declaration);
 931
 932                Id := Defining_Identifier (Decl);
 933                Set_Enclosing_Scope (Id, Entry_Nam);
 934                Next (Decl);
 935             end loop;
 936          end;
 937       end if;
 938
 939       --  If statements are present, they must be analyzed in the context of
 940       --  the entry, so that references to formals are correctly resolved. We
 941       --  also have to add the declarations that are required by the expansion
 942       --  of the accept statement in this case if expansion active.
 943
 944       --  In the case of a select alternative of a selective accept, the
 945       --  expander references the address declaration even if there is no
 946       --  statement list.
 947
 948       --  We also need to create the renaming declarations for the local
 949       --  variables that will replace references to the formals within the
 950       --  accept statement.
 951
 952       Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
 953
 954       --  Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
 955       --  fields on all entry formals (this loop ignores all other entities).
 956       --  Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
 957       --  well, so that we can post accurate warnings on each accept statement
 958       --  for the same entry.
 959
 960       E := First_Entity (Entry_Nam);
 961       while Present (E) loop
 962          if Is_Formal (E) then
 963             Set_Never_Set_In_Source         (E, True);
 964             Set_Is_True_Constant            (E, False);
 965             Set_Current_Value               (E, Empty);
 966             Set_Referenced                  (E, False);
 967             Set_Referenced_As_LHS           (E, False);
 968             Set_Referenced_As_Out_Parameter (E, False);
 969             Set_Has_Pragma_Unreferenced     (E, False);
 970          end if;
 971
 972          Next_Entity (E);
 973       end loop;
 974
 975       --  Analyze statements if present
 976
 977       if Present (Stats) then
 978          Push_Scope (Entry_Nam);
 979          Install_Declarations (Entry_Nam);
 980
 981          Set_Actual_Subtypes (N, Current_Scope);
 982
 983          Analyze (Stats);
 984          Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
 985          End_Scope;
 986       end if;
 987
 988       --  Some warning checks
 989
 990       Check_Potentially_Blocking_Operation (N);
 991       Check_References (Entry_Nam, N);
 992       Set_Entry_Accepted (Entry_Nam);
 993    end Analyze_Accept_Statement;
 994
 995    ---------------------------------
 996    -- Analyze_Asynchronous_Select --
 997    ---------------------------------
 998
 999    procedure Analyze_Asynchronous_Select (N : Node_Id) is
1000       Is_Disp_Select : Boolean := False;
1001       Trigger        : Node_Id;
1002
1003    begin
1004       Tasking_Used := True;
1005       Check_SPARK_Restriction ("select statement is not allowed", N);
1006       Check_Restriction (Max_Asynchronous_Select_Nesting, N);
1007       Check_Restriction (No_Select_Statements, N);
1008
1009       if Ada_Version >= Ada_2005 then
1010          Trigger := Triggering_Statement (Triggering_Alternative (N));
1011
1012          Analyze (Trigger);
1013
1014          --  Ada 2005 (AI-345): Check for a potential dispatching select
1015
1016          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1017       end if;
1018
1019       --  Ada 2005 (AI-345): The expansion of the dispatching asynchronous
1020       --  select will have to duplicate the triggering statements. Postpone
1021       --  the analysis of the statements till expansion. Analyze only if the
1022       --  expander is disabled in order to catch any semantic errors.
1023
1024       if Is_Disp_Select then
1025          if not Expander_Active then
1026             Analyze_Statements (Statements (Abortable_Part (N)));
1027             Analyze (Triggering_Alternative (N));
1028          end if;
1029
1030       --  Analyze the statements. We analyze statements in the abortable part,
1031       --  because this is the section that is executed first, and that way our
1032       --  remembering of saved values and checks is accurate.
1033
1034       else
1035          Analyze_Statements (Statements (Abortable_Part (N)));
1036          Analyze (Triggering_Alternative (N));
1037       end if;
1038    end Analyze_Asynchronous_Select;
1039
1040    ------------------------------------
1041    -- Analyze_Conditional_Entry_Call --
1042    ------------------------------------
1043
1044    procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
1045       Trigger        : constant Node_Id :=
1046                          Entry_Call_Statement (Entry_Call_Alternative (N));
1047       Is_Disp_Select : Boolean := False;
1048
1049    begin
1050       Tasking_Used := True;
1051       Check_SPARK_Restriction ("select statement is not allowed", N);
1052       Check_Restriction (No_Select_Statements, N);
1053
1054       --  Ada 2005 (AI-345): The trigger may be a dispatching call
1055
1056       if Ada_Version >= Ada_2005 then
1057          Analyze (Trigger);
1058          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1059       end if;
1060
1061       if List_Length (Else_Statements (N)) = 1
1062         and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
1063       then
1064          Error_Msg_N
1065            ("suspicious form of conditional entry call??!", N);
1066          Error_Msg_N
1067            ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N);
1068       end if;
1069
1070       --  Postpone the analysis of the statements till expansion. Analyze only
1071       --  if the expander is disabled in order to catch any semantic errors.
1072
1073       if Is_Disp_Select then
1074          if not Expander_Active then
1075             Analyze (Entry_Call_Alternative (N));
1076             Analyze_Statements (Else_Statements (N));
1077          end if;
1078
1079       --  Regular select analysis
1080
1081       else
1082          Analyze (Entry_Call_Alternative (N));
1083          Analyze_Statements (Else_Statements (N));
1084       end if;
1085    end Analyze_Conditional_Entry_Call;
1086
1087    --------------------------------
1088    -- Analyze_Delay_Alternative  --
1089    --------------------------------
1090
1091    procedure Analyze_Delay_Alternative (N : Node_Id) is
1092       Expr : Node_Id;
1093       Typ  : Entity_Id;
1094
1095    begin
1096       Tasking_Used := True;
1097       Check_Restriction (No_Delay, N);
1098
1099       if Present (Pragmas_Before (N)) then
1100          Analyze_List (Pragmas_Before (N));
1101       end if;
1102
1103       if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
1104          Expr := Expression (Delay_Statement (N));
1105
1106          --  Defer full analysis until the statement is expanded, to insure
1107          --  that generated code does not move past the guard. The delay
1108          --  expression is only evaluated if the guard is open.
1109
1110          if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
1111             Preanalyze_And_Resolve (Expr, Standard_Duration);
1112          else
1113             Preanalyze_And_Resolve (Expr);
1114          end if;
1115
1116          Typ := First_Subtype (Etype (Expr));
1117
1118          if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
1119            and then not Is_RTE (Typ, RO_CA_Time)
1120            and then not Is_RTE (Typ, RO_RT_Time)
1121          then
1122             Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
1123          end if;
1124
1125          Check_Restriction (No_Fixed_Point, Expr);
1126
1127       else
1128          Analyze (Delay_Statement (N));
1129       end if;
1130
1131       if Present (Condition (N)) then
1132          Analyze_And_Resolve (Condition (N), Any_Boolean);
1133       end if;
1134
1135       if Is_Non_Empty_List (Statements (N)) then
1136          Analyze_Statements (Statements (N));
1137       end if;
1138    end Analyze_Delay_Alternative;
1139
1140    ----------------------------
1141    -- Analyze_Delay_Relative --
1142    ----------------------------
1143
1144    procedure Analyze_Delay_Relative (N : Node_Id) is
1145       E : constant Node_Id := Expression (N);
1146    begin
1147       Tasking_Used := True;
1148       Check_SPARK_Restriction ("delay statement is not allowed", N);
1149       Check_Restriction (No_Relative_Delay, N);
1150       Check_Restriction (No_Delay, N);
1151       Check_Potentially_Blocking_Operation (N);
1152       Analyze_And_Resolve (E, Standard_Duration);
1153       Check_Restriction (No_Fixed_Point, E);
1154    end Analyze_Delay_Relative;
1155
1156    -------------------------
1157    -- Analyze_Delay_Until --
1158    -------------------------
1159
1160    procedure Analyze_Delay_Until (N : Node_Id) is
1161       E   : constant Node_Id := Expression (N);
1162       Typ : Entity_Id;
1163
1164    begin
1165       Tasking_Used := True;
1166       Check_SPARK_Restriction ("delay statement is not allowed", N);
1167       Check_Restriction (No_Delay, N);
1168       Check_Potentially_Blocking_Operation (N);
1169       Analyze (E);
1170       Typ := First_Subtype (Etype (E));
1171
1172       if not Is_RTE (Typ, RO_CA_Time) and then
1173          not Is_RTE (Typ, RO_RT_Time)
1174       then
1175          Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
1176       end if;
1177    end Analyze_Delay_Until;
1178
1179    ------------------------
1180    -- Analyze_Entry_Body --
1181    ------------------------
1182
1183    procedure Analyze_Entry_Body (N : Node_Id) is
1184       Id         : constant Entity_Id := Defining_Identifier (N);
1185       Decls      : constant List_Id   := Declarations (N);
1186       Stats      : constant Node_Id   := Handled_Statement_Sequence (N);
1187       Formals    : constant Node_Id   := Entry_Body_Formal_Part (N);
1188       P_Type     : constant Entity_Id := Current_Scope;
1189       E          : Entity_Id;
1190       Entry_Name : Entity_Id;
1191
1192    begin
1193       Tasking_Used := True;
1194
1195       --  Entry_Name is initialized to Any_Id. It should get reset to the
1196       --  matching entry entity. An error is signalled if it is not reset
1197
1198       Entry_Name := Any_Id;
1199
1200       Analyze (Formals);
1201
1202       if Present (Entry_Index_Specification (Formals)) then
1203          Set_Ekind (Id, E_Entry_Family);
1204       else
1205          Set_Ekind (Id, E_Entry);
1206       end if;
1207
1208       Set_Scope          (Id, Current_Scope);
1209       Set_Etype          (Id, Standard_Void_Type);
1210       Set_Accept_Address (Id, New_Elmt_List);
1211
1212       E := First_Entity (P_Type);
1213       while Present (E) loop
1214          if Chars (E) = Chars (Id)
1215            and then (Ekind (E) = Ekind (Id))
1216            and then Type_Conformant (Id, E)
1217          then
1218             Entry_Name := E;
1219             Set_Convention (Id, Convention (E));
1220             Set_Corresponding_Body (Parent (Entry_Name), Id);
1221             Check_Fully_Conformant (Id, E, N);
1222
1223             if Ekind (Id) = E_Entry_Family then
1224                if not Fully_Conformant_Discrete_Subtypes (
1225                   Discrete_Subtype_Definition (Parent (E)),
1226                   Discrete_Subtype_Definition
1227                     (Entry_Index_Specification (Formals)))
1228                then
1229                   Error_Msg_N
1230                     ("index not fully conformant with previous declaration",
1231                       Discrete_Subtype_Definition
1232                        (Entry_Index_Specification (Formals)));
1233
1234                else
1235                   --  The elaboration of the entry body does not recompute the
1236                   --  bounds of the index, which may have side effects. Inherit
1237                   --  the bounds from the entry declaration. This is critical
1238                   --  if the entry has a per-object constraint. If a bound is
1239                   --  given by a discriminant, it must be reanalyzed in order
1240                   --  to capture the discriminal of the current entry, rather
1241                   --  than that of the protected type.
1242
1243                   declare
1244                      Index_Spec : constant Node_Id :=
1245                                     Entry_Index_Specification (Formals);
1246
1247                      Def : constant Node_Id :=
1248                              New_Copy_Tree
1249                                (Discrete_Subtype_Definition (Parent (E)));
1250
1251                   begin
1252                      if Nkind
1253                        (Original_Node
1254                          (Discrete_Subtype_Definition (Index_Spec))) = N_Range
1255                      then
1256                         Set_Etype (Def, Empty);
1257                         Set_Analyzed (Def, False);
1258
1259                         --  Keep the original subtree to ensure a properly
1260                         --  formed tree (e.g. for ASIS use).
1261
1262                         Rewrite
1263                           (Discrete_Subtype_Definition (Index_Spec), Def);
1264
1265                         Set_Analyzed (Low_Bound (Def), False);
1266                         Set_Analyzed (High_Bound (Def), False);
1267
1268                         if Denotes_Discriminant (Low_Bound (Def)) then
1269                            Set_Entity (Low_Bound (Def), Empty);
1270                         end if;
1271
1272                         if Denotes_Discriminant (High_Bound (Def)) then
1273                            Set_Entity (High_Bound (Def), Empty);
1274                         end if;
1275
1276                         Analyze (Def);
1277                         Make_Index (Def, Index_Spec);
1278                         Set_Etype
1279                           (Defining_Identifier (Index_Spec), Etype (Def));
1280                      end if;
1281                   end;
1282                end if;
1283             end if;
1284
1285             exit;
1286          end if;
1287
1288          Next_Entity (E);
1289       end loop;
1290
1291       if Entry_Name = Any_Id then
1292          Error_Msg_N ("no entry declaration matches entry body",  N);
1293          return;
1294
1295       elsif Has_Completion (Entry_Name) then
1296          Error_Msg_N ("duplicate entry body", N);
1297          return;
1298
1299       else
1300          Set_Has_Completion (Entry_Name);
1301          Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
1302          Style.Check_Identifier (Id, Entry_Name);
1303       end if;
1304
1305       Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
1306       Push_Scope (Entry_Name);
1307
1308       Install_Declarations (Entry_Name);
1309       Set_Actual_Subtypes (N, Current_Scope);
1310
1311       --  The entity for the protected subprogram corresponding to the entry
1312       --  has been created. We retain the name of this entity in the entry
1313       --  body, for use when the corresponding subprogram body is created.
1314       --  Note that entry bodies have no corresponding_spec, and there is no
1315       --  easy link back in the tree between the entry body and the entity for
1316       --  the entry itself, which is why we must propagate some attributes
1317       --  explicitly from spec to body.
1318
1319       Set_Protected_Body_Subprogram
1320         (Id, Protected_Body_Subprogram (Entry_Name));
1321
1322       Set_Entry_Parameters_Type
1323         (Id, Entry_Parameters_Type (Entry_Name));
1324
1325       --  Add a declaration for the Protection object, renaming declarations
1326       --  for the discriminals and privals and finally a declaration for the
1327       --  entry family index (if applicable).
1328
1329       if Full_Expander_Active
1330         and then Is_Protected_Type (P_Type)
1331       then
1332          Install_Private_Data_Declarations
1333            (Sloc (N), Entry_Name, P_Type, N, Decls);
1334       end if;
1335
1336       if Present (Decls) then
1337          Analyze_Declarations (Decls);
1338          Inspect_Deferred_Constant_Completion (Decls);
1339       end if;
1340
1341       if Present (Stats) then
1342          Analyze (Stats);
1343       end if;
1344
1345       --  Check for unreferenced variables etc. Before the Check_References
1346       --  call, we transfer Never_Set_In_Source and Referenced flags from
1347       --  parameters in the spec to the corresponding entities in the body,
1348       --  since we want the warnings on the body entities. Note that we do not
1349       --  have to transfer Referenced_As_LHS, since that flag can only be set
1350       --  for simple variables, but we include Has_Pragma_Unreferenced,
1351       --  which may have been specified for a formal in the body.
1352
1353       --  At the same time, we set the flags on the spec entities to suppress
1354       --  any warnings on the spec formals, since we also scan the spec.
1355       --  Finally, we propagate the Entry_Component attribute to the body
1356       --  formals, for use in the renaming declarations created later for the
1357       --  formals (see exp_ch9.Add_Formal_Renamings).
1358
1359       declare
1360          E1 : Entity_Id;
1361          E2 : Entity_Id;
1362
1363       begin
1364          E1 := First_Entity (Entry_Name);
1365          while Present (E1) loop
1366             E2 := First_Entity (Id);
1367             while Present (E2) loop
1368                exit when Chars (E1) = Chars (E2);
1369                Next_Entity (E2);
1370             end loop;
1371
1372             --  If no matching body entity, then we already had a detected
1373             --  error of some kind, so just don't worry about these warnings.
1374
1375             if No (E2) then
1376                goto Continue;
1377             end if;
1378
1379             if Ekind (E1) = E_Out_Parameter then
1380                Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
1381                Set_Never_Set_In_Source (E1, False);
1382             end if;
1383
1384             Set_Referenced (E2, Referenced (E1));
1385             Set_Referenced (E1);
1386             Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1));
1387             Set_Entry_Component (E2, Entry_Component (E1));
1388
1389          <<Continue>>
1390             Next_Entity (E1);
1391          end loop;
1392
1393          Check_References (Id);
1394       end;
1395
1396       --  We still need to check references for the spec, since objects
1397       --  declared in the body are chained (in the First_Entity sense) to
1398       --  the spec rather than the body in the case of entries.
1399
1400       Check_References (Entry_Name);
1401
1402       --  Process the end label, and terminate the scope
1403
1404       Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
1405       End_Scope;
1406
1407       --  If this is an entry family, remove the loop created to provide
1408       --  a scope for the entry index.
1409
1410       if Ekind (Id) = E_Entry_Family
1411         and then Present (Entry_Index_Specification (Formals))
1412       then
1413          End_Scope;
1414       end if;
1415    end Analyze_Entry_Body;
1416
1417    ------------------------------------
1418    -- Analyze_Entry_Body_Formal_Part --
1419    ------------------------------------
1420
1421    procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
1422       Id      : constant Entity_Id := Defining_Identifier (Parent (N));
1423       Index   : constant Node_Id   := Entry_Index_Specification (N);
1424       Formals : constant List_Id   := Parameter_Specifications (N);
1425
1426    begin
1427       Tasking_Used := True;
1428
1429       if Present (Index) then
1430          Analyze (Index);
1431
1432          --  The entry index functions like a loop variable, thus it is known
1433          --  to have a valid value.
1434
1435          Set_Is_Known_Valid (Defining_Identifier (Index));
1436       end if;
1437
1438       if Present (Formals) then
1439          Set_Scope (Id, Current_Scope);
1440          Push_Scope (Id);
1441          Process_Formals (Formals, Parent (N));
1442          End_Scope;
1443       end if;
1444    end Analyze_Entry_Body_Formal_Part;
1445
1446    ------------------------------------
1447    -- Analyze_Entry_Call_Alternative --
1448    ------------------------------------
1449
1450    procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
1451       Call : constant Node_Id := Entry_Call_Statement (N);
1452
1453    begin
1454       Tasking_Used := True;
1455       Check_SPARK_Restriction ("entry call is not allowed", N);
1456
1457       if Present (Pragmas_Before (N)) then
1458          Analyze_List (Pragmas_Before (N));
1459       end if;
1460
1461       if Nkind (Call) = N_Attribute_Reference then
1462
1463          --  Possibly a stream attribute, but definitely illegal. Other
1464          --  illegalities, such as procedure calls, are diagnosed after
1465          --  resolution.
1466
1467          Error_Msg_N ("entry call alternative requires an entry call", Call);
1468          return;
1469       end if;
1470
1471       Analyze (Call);
1472
1473       --  An indirect call in this context is illegal. A procedure call that
1474       --  does not involve a renaming of an entry is illegal as well, but this
1475       --  and other semantic errors are caught during resolution.
1476
1477       if Nkind (Call) = N_Explicit_Dereference then
1478          Error_Msg_N
1479            ("entry call or dispatching primitive of interface required ", N);
1480       end if;
1481
1482       if Is_Non_Empty_List (Statements (N)) then
1483          Analyze_Statements (Statements (N));
1484       end if;
1485    end Analyze_Entry_Call_Alternative;
1486
1487    -------------------------------
1488    -- Analyze_Entry_Declaration --
1489    -------------------------------
1490
1491    procedure Analyze_Entry_Declaration (N : Node_Id) is
1492       D_Sdef  : constant Node_Id   := Discrete_Subtype_Definition (N);
1493       Def_Id  : constant Entity_Id := Defining_Identifier (N);
1494       Formals : constant List_Id   := Parameter_Specifications (N);
1495
1496    begin
1497       Generate_Definition (Def_Id);
1498       Set_Contract (Def_Id, Make_Contract (Sloc (Def_Id)));
1499       Tasking_Used := True;
1500
1501       --  Case of no discrete subtype definition
1502
1503       if No (D_Sdef) then
1504          Set_Ekind (Def_Id, E_Entry);
1505
1506       --  Processing for discrete subtype definition present
1507
1508       else
1509          Enter_Name (Def_Id);
1510          Set_Ekind (Def_Id, E_Entry_Family);
1511          Analyze (D_Sdef);
1512          Make_Index (D_Sdef, N, Def_Id);
1513
1514          --  Check subtype with predicate in entry family
1515
1516          Bad_Predicated_Subtype_Use
1517            ("subtype& has predicate, not allowed in entry family",
1518             D_Sdef, Etype (D_Sdef));
1519
1520          --  Check entry family static bounds outside allowed limits
1521
1522          --  Note: originally this check was not performed here, but in that
1523          --  case the check happens deep in the expander, and the message is
1524          --  posted at the wrong location, and omitted in -gnatc mode.
1525          --  If the type of the entry index is a generic formal, no check
1526          --  is possible. In an instance, the check is not static and a run-
1527          --  time exception will be raised if the bounds are unreasonable.
1528
1529          declare
1530             PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
1531             LB  : constant Uint      := Expr_Value (Type_Low_Bound (PEI));
1532             UB  : constant Uint      := Expr_Value (Type_High_Bound (PEI));
1533
1534             LBR : Node_Id;
1535             UBR : Node_Id;
1536
1537          begin
1538
1539             --  No bounds checking if the type is generic or if previous error.
1540             --  In an instance the check is dynamic.
1541
1542             if Is_Generic_Type (Etype (D_Sdef))
1543               or else In_Instance
1544               or else Error_Posted (D_Sdef)
1545             then
1546                goto Skip_LB;
1547
1548             elsif Nkind (D_Sdef) = N_Range then
1549                LBR := Low_Bound (D_Sdef);
1550
1551             elsif Is_Entity_Name (D_Sdef)
1552               and then Is_Type (Entity (D_Sdef))
1553             then
1554                LBR := Type_Low_Bound (Entity (D_Sdef));
1555
1556             else
1557                goto Skip_LB;
1558             end if;
1559
1560             if Is_Static_Expression (LBR)
1561               and then Expr_Value (LBR) < LB
1562             then
1563                Error_Msg_Uint_1 := LB;
1564                Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
1565             end if;
1566
1567          <<Skip_LB>>
1568             if Is_Generic_Type (Etype (D_Sdef))
1569               or else In_Instance
1570               or else Error_Posted (D_Sdef)
1571             then
1572                goto Skip_UB;
1573
1574             elsif Nkind (D_Sdef) = N_Range then
1575                UBR := High_Bound (D_Sdef);
1576
1577             elsif Is_Entity_Name (D_Sdef)
1578               and then Is_Type (Entity (D_Sdef))
1579             then
1580                UBR := Type_High_Bound (Entity (D_Sdef));
1581
1582             else
1583                goto Skip_UB;
1584             end if;
1585
1586             if Is_Static_Expression (UBR)
1587               and then Expr_Value (UBR) > UB
1588             then
1589                Error_Msg_Uint_1 := UB;
1590                Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
1591             end if;
1592
1593          <<Skip_UB>>
1594             null;
1595          end;
1596       end if;
1597
1598       --  Decorate Def_Id
1599
1600       Set_Etype          (Def_Id, Standard_Void_Type);
1601       Set_Convention     (Def_Id, Convention_Entry);
1602       Set_Accept_Address (Def_Id, New_Elmt_List);
1603
1604       --  Process formals
1605
1606       if Present (Formals) then
1607          Set_Scope (Def_Id, Current_Scope);
1608          Push_Scope (Def_Id);
1609          Process_Formals (Formals, N);
1610          Create_Extra_Formals (Def_Id);
1611          End_Scope;
1612       end if;
1613
1614       if Ekind (Def_Id) = E_Entry then
1615          New_Overloaded_Entity (Def_Id);
1616       end if;
1617
1618       Generate_Reference_To_Formals (Def_Id);
1619
1620       if Has_Aspects (N) then
1621          Analyze_Aspect_Specifications (N, Def_Id);
1622       end if;
1623    end Analyze_Entry_Declaration;
1624
1625    ---------------------------------------
1626    -- Analyze_Entry_Index_Specification --
1627    ---------------------------------------
1628
1629    --  The Defining_Identifier of the entry index specification is local to the
1630    --  entry body, but it must be available in the entry barrier which is
1631    --  evaluated outside of the entry body. The index is eventually renamed as
1632    --  a run-time object, so is visibility is strictly a front-end concern. In
1633    --  order to make it available to the barrier, we create an additional
1634    --  scope, as for a loop, whose only declaration is the index name. This
1635    --  loop is not attached to the tree and does not appear as an entity local
1636    --  to the protected type, so its existence need only be known to routines
1637    --  that process entry families.
1638
1639    procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1640       Iden    : constant Node_Id   := Defining_Identifier (N);
1641       Def     : constant Node_Id   := Discrete_Subtype_Definition (N);
1642       Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
1643
1644    begin
1645       Tasking_Used := True;
1646       Analyze (Def);
1647
1648       --  There is no elaboration of the entry index specification. Therefore,
1649       --  if the index is a range, it is not resolved and expanded, but the
1650       --  bounds are inherited from the entry declaration, and reanalyzed.
1651       --  See Analyze_Entry_Body.
1652
1653       if Nkind (Def) /= N_Range then
1654          Make_Index (Def, N);
1655       end if;
1656
1657       Set_Ekind (Loop_Id, E_Loop);
1658       Set_Scope (Loop_Id, Current_Scope);
1659       Push_Scope (Loop_Id);
1660       Enter_Name (Iden);
1661       Set_Ekind (Iden, E_Entry_Index_Parameter);
1662       Set_Etype (Iden, Etype (Def));
1663    end Analyze_Entry_Index_Specification;
1664
1665    ----------------------------
1666    -- Analyze_Protected_Body --
1667    ----------------------------
1668
1669    procedure Analyze_Protected_Body (N : Node_Id) is
1670       Body_Id : constant Entity_Id := Defining_Identifier (N);
1671       Last_E  : Entity_Id;
1672
1673       Spec_Id : Entity_Id;
1674       --  This is initially the entity of the protected object or protected
1675       --  type involved, but is replaced by the protected type always in the
1676       --  case of a single protected declaration, since this is the proper
1677       --  scope to be used.
1678
1679       Ref_Id : Entity_Id;
1680       --  This is the entity of the protected object or protected type
1681       --  involved, and is the entity used for cross-reference purposes (it
1682       --  differs from Spec_Id in the case of a single protected object, since
1683       --  Spec_Id is set to the protected type in this case).
1684
1685       function Lock_Free_Disabled return Boolean;
1686       --  This routine returns False if the protected object has a Lock_Free
1687       --  aspect specification or a Lock_Free pragma that turns off the
1688       --  lock-free implementation (e.g. whose expression is False).
1689
1690       ------------------------
1691       -- Lock_Free_Disabled --
1692       ------------------------
1693
1694       function Lock_Free_Disabled return Boolean is
1695          Ritem : constant Node_Id :=
1696                    Get_Rep_Item
1697                      (Spec_Id, Name_Lock_Free, Check_Parents => False);
1698
1699       begin
1700          if Present (Ritem) then
1701
1702             --  Pragma with one argument
1703
1704             if Nkind (Ritem) = N_Pragma
1705               and then Present (Pragma_Argument_Associations (Ritem))
1706             then
1707                return
1708                  Is_False
1709                    (Static_Boolean
1710                      (Expression
1711                        (First (Pragma_Argument_Associations (Ritem)))));
1712
1713             --  Aspect Specification with expression present
1714
1715             elsif Nkind (Ritem) = N_Aspect_Specification
1716               and then Present (Expression (Ritem))
1717             then
1718                return Is_False (Static_Boolean (Expression (Ritem)));
1719
1720             --  Otherwise, return False
1721
1722             else
1723                return False;
1724             end if;
1725          end if;
1726
1727          return False;
1728       end Lock_Free_Disabled;
1729
1730    --  Start of processing for Analyze_Protected_Body
1731
1732    begin
1733       Tasking_Used := True;
1734       Set_Ekind (Body_Id, E_Protected_Body);
1735       Spec_Id := Find_Concurrent_Spec (Body_Id);
1736
1737       if Present (Spec_Id)
1738         and then Ekind (Spec_Id) = E_Protected_Type
1739       then
1740          null;
1741
1742       elsif Present (Spec_Id)
1743         and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1744         and then not Comes_From_Source (Etype (Spec_Id))
1745       then
1746          null;
1747
1748       else
1749          Error_Msg_N ("missing specification for protected body", Body_Id);
1750          return;
1751       end if;
1752
1753       Ref_Id := Spec_Id;
1754       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1755       Style.Check_Identifier (Body_Id, Spec_Id);
1756
1757       --  The declarations are always attached to the type
1758
1759       if Ekind (Spec_Id) /= E_Protected_Type then
1760          Spec_Id := Etype (Spec_Id);
1761       end if;
1762
1763       Push_Scope (Spec_Id);
1764       Set_Corresponding_Spec (N, Spec_Id);
1765       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1766       Set_Has_Completion (Spec_Id);
1767       Install_Declarations (Spec_Id);
1768
1769       Expand_Protected_Body_Declarations (N, Spec_Id);
1770
1771       Last_E := Last_Entity (Spec_Id);
1772
1773       Analyze_Declarations (Declarations (N));
1774
1775       --  For visibility purposes, all entities in the body are private. Set
1776       --  First_Private_Entity accordingly, if there was no private part in the
1777       --  protected declaration.
1778
1779       if No (First_Private_Entity (Spec_Id)) then
1780          if Present (Last_E) then
1781             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1782          else
1783             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1784          end if;
1785       end if;
1786
1787       Check_Completion (Body_Id);
1788       Check_References (Spec_Id);
1789       Process_End_Label (N, 't', Ref_Id);
1790       End_Scope;
1791
1792       --  When a Lock_Free aspect specification/pragma forces the lock-free
1793       --  implementation, verify the protected body meets all the restrictions,
1794       --  otherwise Allows_Lock_Free_Implementation issues an error message.
1795
1796       if Uses_Lock_Free (Spec_Id) then
1797          if not Allows_Lock_Free_Implementation (N, True) then
1798             return;
1799          end if;
1800
1801       --  In other cases, if there is no aspect specification/pragma that
1802       --  disables the lock-free implementation, check both the protected
1803       --  declaration and body satisfy the lock-free restrictions.
1804
1805       elsif not Lock_Free_Disabled
1806         and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
1807         and then Allows_Lock_Free_Implementation (N)
1808       then
1809          Set_Uses_Lock_Free (Spec_Id);
1810       end if;
1811    end Analyze_Protected_Body;
1812
1813    ----------------------------------
1814    -- Analyze_Protected_Definition --
1815    ----------------------------------
1816
1817    procedure Analyze_Protected_Definition (N : Node_Id) is
1818       E : Entity_Id;
1819       L : Entity_Id;
1820
1821       procedure Undelay_Itypes (T : Entity_Id);
1822       --  Itypes created for the private components of a protected type
1823       --  do not receive freeze nodes, because there is no scope in which
1824       --  they can be elaborated, and they can depend on discriminants of
1825       --  the enclosed protected type. Given that the components can be
1826       --  composite types with inner components, we traverse recursively
1827       --  the private components of the protected type, and indicate that
1828       --  all itypes within are frozen. This ensures that no freeze nodes
1829       --  will be generated for them.
1830       --
1831       --  On the other hand, components of the corresponding record are
1832       --  frozen (or receive itype references) as for other records.
1833
1834       --------------------
1835       -- Undelay_Itypes --
1836       --------------------
1837
1838       procedure Undelay_Itypes (T : Entity_Id) is
1839          Comp : Entity_Id;
1840
1841       begin
1842          if Is_Protected_Type (T) then
1843             Comp := First_Private_Entity (T);
1844          elsif Is_Record_Type (T) then
1845             Comp := First_Entity (T);
1846          else
1847             return;
1848          end if;
1849
1850          while Present (Comp) loop
1851             if Is_Type (Comp)
1852               and then Is_Itype (Comp)
1853             then
1854                Set_Has_Delayed_Freeze (Comp, False);
1855                Set_Is_Frozen (Comp);
1856
1857                if Is_Record_Type (Comp)
1858                  or else Is_Protected_Type (Comp)
1859                then
1860                   Undelay_Itypes (Comp);
1861                end if;
1862             end if;
1863
1864             Next_Entity (Comp);
1865          end loop;
1866       end Undelay_Itypes;
1867
1868    --  Start of processing for Analyze_Protected_Definition
1869
1870    begin
1871       Tasking_Used := True;
1872       Check_SPARK_Restriction ("protected definition is not allowed", N);
1873       Analyze_Declarations (Visible_Declarations (N));
1874
1875       if Present (Private_Declarations (N))
1876         and then not Is_Empty_List (Private_Declarations (N))
1877       then
1878          L := Last_Entity (Current_Scope);
1879          Analyze_Declarations (Private_Declarations (N));
1880
1881          if Present (L) then
1882             Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1883          else
1884             Set_First_Private_Entity (Current_Scope,
1885               First_Entity (Current_Scope));
1886          end if;
1887       end if;
1888
1889       E := First_Entity (Current_Scope);
1890       while Present (E) loop
1891          if Ekind_In (E, E_Function, E_Procedure) then
1892             Set_Convention (E, Convention_Protected);
1893
1894          elsif Is_Task_Type (Etype (E))
1895            or else Has_Task (Etype (E))
1896          then
1897             Set_Has_Task (Current_Scope);
1898          end if;
1899
1900          Next_Entity (E);
1901       end loop;
1902
1903       Undelay_Itypes (Current_Scope);
1904
1905       Check_Max_Entries (N, Max_Protected_Entries);
1906       Process_End_Label (N, 'e', Current_Scope);
1907    end Analyze_Protected_Definition;
1908
1909    ----------------------------------------
1910    -- Analyze_Protected_Type_Declaration --
1911    ----------------------------------------
1912
1913    procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
1914       Def_Id : constant Entity_Id := Defining_Identifier (N);
1915       E      : Entity_Id;
1916       T      : Entity_Id;
1917
1918    begin
1919       if No_Run_Time_Mode then
1920          Error_Msg_CRT ("protected type", N);
1921
1922          if Has_Aspects (N) then
1923             Analyze_Aspect_Specifications (N, Def_Id);
1924          end if;
1925
1926          return;
1927       end if;
1928
1929       Tasking_Used := True;
1930       Check_Restriction (No_Protected_Types, N);
1931
1932       T := Find_Type_Name (N);
1933
1934       --  In the case of an incomplete type, use the full view, unless it's not
1935       --  present (as can occur for an incomplete view from a limited with).
1936
1937       if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1938          T := Full_View (T);
1939          Set_Completion_Referenced (T);
1940       end if;
1941
1942       Set_Ekind              (T, E_Protected_Type);
1943       Set_Is_First_Subtype   (T, True);
1944       Init_Size_Align        (T);
1945       Set_Etype              (T, T);
1946       Set_Has_Delayed_Freeze (T, True);
1947       Set_Stored_Constraint  (T, No_Elist);
1948       Push_Scope (T);
1949
1950       if Ada_Version >= Ada_2005 then
1951          Check_Interfaces (N, T);
1952       end if;
1953
1954       if Present (Discriminant_Specifications (N)) then
1955          if Has_Discriminants (T) then
1956
1957             --  Install discriminants. Also, verify conformance of
1958             --  discriminants of previous and current view. ???
1959
1960             Install_Declarations (T);
1961          else
1962             Process_Discriminants (N);
1963          end if;
1964       end if;
1965
1966       Set_Is_Constrained (T, not Has_Discriminants (T));
1967
1968       --  If aspects are present, analyze them now. They can make references
1969       --  to the discriminants of the type, but not to any components.
1970
1971       if Has_Aspects (N) then
1972          Analyze_Aspect_Specifications (N, Def_Id);
1973       end if;
1974
1975       Analyze (Protected_Definition (N));
1976
1977       --  In the case where the protected type is declared at a nested level
1978       --  and the No_Local_Protected_Objects restriction applies, issue a
1979       --  warning that objects of the type will violate the restriction.
1980
1981       if Restriction_Check_Required (No_Local_Protected_Objects)
1982         and then not Is_Library_Level_Entity (T)
1983         and then Comes_From_Source (T)
1984       then
1985          Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
1986
1987          if Error_Msg_Sloc = No_Location then
1988             Error_Msg_N
1989               ("objects of this type will violate " &
1990                "`No_Local_Protected_Objects`??", N);
1991          else
1992             Error_Msg_N
1993               ("objects of this type will violate " &
1994                "`No_Local_Protected_Objects`#??", N);
1995          end if;
1996       end if;
1997
1998       --  Protected types with entries are controlled (because of the
1999       --  Protection component if nothing else), same for any protected type
2000       --  with interrupt handlers. Note that we need to analyze the protected
2001       --  definition to set Has_Entries and such.
2002
2003       if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
2004            or else Number_Entries (T) > 1)
2005         and then
2006           (Has_Entries (T)
2007             or else Has_Interrupt_Handler (T)
2008             or else Has_Attach_Handler (T))
2009       then
2010          Set_Has_Controlled_Component (T, True);
2011       end if;
2012
2013       --  The Ekind of components is E_Void during analysis to detect illegal
2014       --  uses. Now it can be set correctly.
2015
2016       E := First_Entity (Current_Scope);
2017       while Present (E) loop
2018          if Ekind (E) = E_Void then
2019             Set_Ekind (E, E_Component);
2020             Init_Component_Location (E);
2021          end if;
2022
2023          Next_Entity (E);
2024       end loop;
2025
2026       End_Scope;
2027
2028       --  When a Lock_Free aspect forces the lock-free implementation, check N
2029       --  meets all the lock-free restrictions. Otherwise, an error message is
2030       --  issued by Allows_Lock_Free_Implementation.
2031
2032       if Uses_Lock_Free (Defining_Identifier (N)) then
2033
2034          --  Complain when there is an explicit aspect/pragma Priority (or
2035          --  Interrupt_Priority) while the lock-free implementation is forced
2036          --  by an aspect/pragma.
2037
2038          declare
2039             Id : constant Entity_Id := Defining_Identifier (Original_Node (N));
2040             --  The warning must be issued on the original identifier in order
2041             --  to deal properly with the case of a single protected object.
2042
2043             Prio_Item : constant Node_Id :=
2044                           Get_Rep_Item (Def_Id, Name_Priority, False);
2045
2046          begin
2047             if Present (Prio_Item) then
2048
2049                --  Aspect case
2050
2051                if Nkind (Prio_Item) = N_Aspect_Specification
2052                  or else From_Aspect_Specification (Prio_Item)
2053                then
2054                   Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
2055                   Error_Msg_NE ("aspect% for & has no effect when Lock_Free" &
2056                                 " given??", Prio_Item, Id);
2057
2058                --  Pragma case
2059
2060                else
2061                   Error_Msg_Name_1 := Pragma_Name (Prio_Item);
2062                   Error_Msg_NE ("pragma% for & has no effect when Lock_Free" &
2063                                 " given??", Prio_Item, Id);
2064                end if;
2065             end if;
2066          end;
2067
2068          if not Allows_Lock_Free_Implementation (N, True) then
2069             return;
2070          end if;
2071       end if;
2072
2073       --  If the Attach_Handler aspect is specified or the Interrupt_Handler
2074       --  aspect is True, then the initial ceiling priority must be in the
2075       --  range of System.Interrupt_Priority. It is therefore recommanded
2076       --  to use the Interrupt_Priority aspect instead of the Priority aspect.
2077
2078       if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then
2079          declare
2080             Prio_Item : constant Node_Id :=
2081                           Get_Rep_Item (Def_Id, Name_Priority, False);
2082
2083          begin
2084             if Present (Prio_Item) then
2085
2086                --  Aspect case
2087
2088                if (Nkind (Prio_Item) = N_Aspect_Specification
2089                     or else From_Aspect_Specification (Prio_Item))
2090                  and then Chars (Identifier (Prio_Item)) = Name_Priority
2091                then
2092                   Error_Msg_N ("aspect Interrupt_Priority is preferred "
2093                                & "in presence of handlers??", Prio_Item);
2094
2095                --  Pragma case
2096
2097                elsif Nkind (Prio_Item) = N_Pragma
2098                  and then Pragma_Name (Prio_Item) = Name_Priority
2099                then
2100                   Error_Msg_N ("pragma Interrupt_Priority is preferred "
2101                                & "in presence of handlers??", Prio_Item);
2102                end if;
2103             end if;
2104          end;
2105       end if;
2106
2107       --  Case of a completion of a private declaration
2108
2109       if T /= Def_Id and then Is_Private_Type (Def_Id) then
2110
2111          --  Deal with preelaborable initialization. Note that this processing
2112          --  is done by Process_Full_View, but as can be seen below, in this
2113          --  case the call to Process_Full_View is skipped if any serious
2114          --  errors have occurred, and we don't want to lose this check.
2115
2116          if Known_To_Have_Preelab_Init (Def_Id) then
2117             Set_Must_Have_Preelab_Init (T);
2118          end if;
2119
2120          --  Create corresponding record now, because some private dependents
2121          --  may be subtypes of the partial view.
2122
2123          --  Skip if errors are present, to prevent cascaded messages
2124
2125          if Serious_Errors_Detected = 0
2126
2127            --  Also skip if expander is not active
2128
2129            and then Full_Expander_Active
2130          then
2131             Expand_N_Protected_Type_Declaration (N);
2132             Process_Full_View (N, T, Def_Id);
2133          end if;
2134       end if;
2135    end Analyze_Protected_Type_Declaration;
2136
2137    ---------------------
2138    -- Analyze_Requeue --
2139    ---------------------
2140
2141    procedure Analyze_Requeue (N : Node_Id) is
2142       Count       : Natural := 0;
2143       Entry_Name  : Node_Id := Name (N);
2144       Entry_Id    : Entity_Id;
2145       I           : Interp_Index;
2146       Is_Disp_Req : Boolean;
2147       It          : Interp;
2148       Enclosing   : Entity_Id;
2149       Target_Obj  : Node_Id := Empty;
2150       Req_Scope   : Entity_Id;
2151       Outer_Ent   : Entity_Id;
2152       Synch_Type  : Entity_Id;
2153
2154    begin
2155       Tasking_Used := True;
2156       Check_SPARK_Restriction ("requeue statement is not allowed", N);
2157       Check_Restriction (No_Requeue_Statements, N);
2158       Check_Unreachable_Code (N);
2159
2160       Enclosing := Empty;
2161       for J in reverse 0 .. Scope_Stack.Last loop
2162          Enclosing := Scope_Stack.Table (J).Entity;
2163          exit when Is_Entry (Enclosing);
2164
2165          if not Ekind_In (Enclosing, E_Block, E_Loop) then
2166             Error_Msg_N ("requeue must appear within accept or entry body", N);
2167             return;
2168          end if;
2169       end loop;
2170
2171       Analyze (Entry_Name);
2172
2173       if Etype (Entry_Name) = Any_Type then
2174          return;
2175       end if;
2176
2177       if Nkind (Entry_Name) = N_Selected_Component then
2178          Target_Obj := Prefix (Entry_Name);
2179          Entry_Name := Selector_Name (Entry_Name);
2180       end if;
2181
2182       --  If an explicit target object is given then we have to check the
2183       --  restrictions of 9.5.4(6).
2184
2185       if Present (Target_Obj) then
2186
2187          --  Locate containing concurrent unit and determine enclosing entry
2188          --  body or outermost enclosing accept statement within the unit.
2189
2190          Outer_Ent := Empty;
2191          for S in reverse 0 .. Scope_Stack.Last loop
2192             Req_Scope := Scope_Stack.Table (S).Entity;
2193
2194             exit when Ekind (Req_Scope) in Task_Kind
2195               or else Ekind (Req_Scope) in Protected_Kind;
2196
2197             if Is_Entry (Req_Scope) then
2198                Outer_Ent := Req_Scope;
2199             end if;
2200          end loop;
2201
2202          pragma Assert (Present (Outer_Ent));
2203
2204          --  Check that the accessibility level of the target object is not
2205          --  greater or equal to the outermost enclosing accept statement (or
2206          --  entry body) unless it is a parameter of the innermost enclosing
2207          --  accept statement (or entry body).
2208
2209          if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
2210            and then
2211              (not Is_Entity_Name (Target_Obj)
2212                or else Ekind (Entity (Target_Obj)) not in Formal_Kind
2213                or else Enclosing /= Scope (Entity (Target_Obj)))
2214          then
2215             Error_Msg_N
2216               ("target object has invalid level for requeue", Target_Obj);
2217          end if;
2218       end if;
2219
2220       --  Overloaded case, find right interpretation
2221
2222       if Is_Overloaded (Entry_Name) then
2223          Entry_Id := Empty;
2224
2225          --  Loop over candidate interpretations and filter out any that are
2226          --  not parameterless, are not type conformant, are not entries, or
2227          --  do not come from source.
2228
2229          Get_First_Interp (Entry_Name, I, It);
2230          while Present (It.Nam) loop
2231
2232             --  Note: we test type conformance here, not subtype conformance.
2233             --  Subtype conformance will be tested later on, but it is better
2234             --  for error output in some cases not to do that here.
2235
2236             if (No (First_Formal (It.Nam))
2237                  or else (Type_Conformant (Enclosing, It.Nam)))
2238               and then Ekind (It.Nam) = E_Entry
2239             then
2240                --  Ada 2005 (AI-345): Since protected and task types have
2241                --  primitive entry wrappers, we only consider source entries.
2242
2243                if Comes_From_Source (It.Nam) then
2244                   Count := Count + 1;
2245                   Entry_Id := It.Nam;
2246                else
2247                   Remove_Interp (I);
2248                end if;
2249             end if;
2250
2251             Get_Next_Interp (I, It);
2252          end loop;
2253
2254          if Count = 0 then
2255             Error_Msg_N ("no entry matches context", N);
2256             return;
2257
2258          elsif Count > 1 then
2259             Error_Msg_N ("ambiguous entry name in requeue", N);
2260             return;
2261
2262          else
2263             Set_Is_Overloaded (Entry_Name, False);
2264             Set_Entity (Entry_Name, Entry_Id);
2265          end if;
2266
2267       --  Non-overloaded cases
2268
2269       --  For the case of a reference to an element of an entry family, the
2270       --  Entry_Name is an indexed component.
2271
2272       elsif Nkind (Entry_Name) = N_Indexed_Component then
2273
2274          --  Requeue to an entry out of the body
2275
2276          if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
2277             Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
2278
2279          --  Requeue from within the body itself
2280
2281          elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
2282             Entry_Id := Entity (Prefix (Entry_Name));
2283
2284          else
2285             Error_Msg_N ("invalid entry_name specified",  N);
2286             return;
2287          end if;
2288
2289       --  If we had a requeue of the form REQUEUE A (B), then the parser
2290       --  accepted it (because it could have been a requeue on an entry index.
2291       --  If A turns out not to be an entry family, then the analysis of A (B)
2292       --  turned it into a function call.
2293
2294       elsif Nkind (Entry_Name) = N_Function_Call then
2295          Error_Msg_N
2296            ("arguments not allowed in requeue statement",
2297             First (Parameter_Associations (Entry_Name)));
2298          return;
2299
2300       --  Normal case of no entry family, no argument
2301
2302       else
2303          Entry_Id := Entity (Entry_Name);
2304       end if;
2305
2306       --  Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
2307       --  target type must be a concurrent interface class-wide type and the
2308       --  target must be a procedure, flagged by pragma Implemented. The
2309       --  target may be an access to class-wide type, in which case it must
2310       --  be dereferenced.
2311
2312       if Present (Target_Obj) then
2313          Synch_Type := Etype (Target_Obj);
2314
2315          if Is_Access_Type (Synch_Type) then
2316             Synch_Type := Designated_Type (Synch_Type);
2317          end if;
2318       end if;
2319
2320       Is_Disp_Req :=
2321         Ada_Version >= Ada_2012
2322           and then Present (Target_Obj)
2323           and then Is_Class_Wide_Type (Synch_Type)
2324           and then Is_Concurrent_Interface (Synch_Type)
2325           and then Ekind (Entry_Id) = E_Procedure
2326           and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
2327
2328       --  Resolve entry, and check that it is subtype conformant with the
2329       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
2330       --  Ada 2005 (AI05-0030): Do not emit an error for this specific case.
2331
2332       if not Is_Entry (Entry_Id)
2333         and then not Is_Disp_Req
2334       then
2335          Error_Msg_N ("expect entry name in requeue statement", Name (N));
2336
2337       elsif Ekind (Entry_Id) = E_Entry_Family
2338         and then Nkind (Entry_Name) /= N_Indexed_Component
2339       then
2340          Error_Msg_N ("missing index for entry family component", Name (N));
2341
2342       else
2343          Resolve_Entry (Name (N));
2344          Generate_Reference (Entry_Id, Entry_Name);
2345
2346          if Present (First_Formal (Entry_Id)) then
2347             if VM_Target = JVM_Target then
2348                Error_Msg_N
2349                  ("arguments unsupported in requeue statement",
2350                   First_Formal (Entry_Id));
2351                return;
2352             end if;
2353
2354             --  Ada 2012 (AI05-0030): Perform type conformance after skipping
2355             --  the first parameter of Entry_Id since it is the interface
2356             --  controlling formal.
2357
2358             if Ada_Version >= Ada_2012 and then Is_Disp_Req then
2359                declare
2360                   Enclosing_Formal : Entity_Id;
2361                   Target_Formal    : Entity_Id;
2362
2363                begin
2364                   Enclosing_Formal := First_Formal (Enclosing);
2365                   Target_Formal := Next_Formal (First_Formal (Entry_Id));
2366                   while Present (Enclosing_Formal)
2367                     and then Present (Target_Formal)
2368                   loop
2369                      if not Conforming_Types
2370                               (T1    => Etype (Enclosing_Formal),
2371                                T2    => Etype (Target_Formal),
2372                                Ctype => Subtype_Conformant)
2373                      then
2374                         Error_Msg_Node_2 := Target_Formal;
2375                         Error_Msg_NE
2376                           ("formal & is not subtype conformant with &" &
2377                            "in dispatching requeue", N, Enclosing_Formal);
2378                      end if;
2379
2380                      Next_Formal (Enclosing_Formal);
2381                      Next_Formal (Target_Formal);
2382                   end loop;
2383                end;
2384             else
2385                Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
2386             end if;
2387
2388             --  Processing for parameters accessed by the requeue
2389
2390             declare
2391                Ent : Entity_Id;
2392
2393             begin
2394                Ent := First_Formal (Enclosing);
2395                while Present (Ent) loop
2396
2397                   --  For OUT or IN OUT parameter, the effect of the requeue is
2398                   --  to assign the parameter a value on exit from the requeued
2399                   --  body, so we can set it as source assigned. We also clear
2400                   --  the Is_True_Constant indication. We do not need to clear
2401                   --  Current_Value, since the effect of the requeue is to
2402                   --  perform an unconditional goto so that any further
2403                   --  references will not occur anyway.
2404
2405                   if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
2406                      Set_Never_Set_In_Source (Ent, False);
2407                      Set_Is_True_Constant    (Ent, False);
2408                   end if;
2409
2410                   --  For all parameters, the requeue acts as a reference,
2411                   --  since the value of the parameter is passed to the new
2412                   --  entry, so we want to suppress unreferenced warnings.
2413
2414                   Set_Referenced (Ent);
2415                   Next_Formal (Ent);
2416                end loop;
2417             end;
2418          end if;
2419       end if;
2420
2421       --  AI05-0225: the target protected object of a requeue must be a
2422       --  variable. This is a binding interpretation that applies to all
2423       --  versions of the language.
2424
2425       if Present (Target_Obj)
2426         and then Ekind (Scope (Entry_Id)) in Protected_Kind
2427         and then not Is_Variable (Target_Obj)
2428       then
2429          Error_Msg_N
2430            ("target protected object of requeue must be a variable", N);
2431       end if;
2432    end Analyze_Requeue;
2433
2434    ------------------------------
2435    -- Analyze_Selective_Accept --
2436    ------------------------------
2437
2438    procedure Analyze_Selective_Accept (N : Node_Id) is
2439       Alts : constant List_Id := Select_Alternatives (N);
2440       Alt  : Node_Id;
2441
2442       Accept_Present    : Boolean := False;
2443       Terminate_Present : Boolean := False;
2444       Delay_Present     : Boolean := False;
2445       Relative_Present  : Boolean := False;
2446       Alt_Count         : Uint    := Uint_0;
2447
2448    begin
2449       Tasking_Used := True;
2450       Check_SPARK_Restriction ("select statement is not allowed", N);
2451       Check_Restriction (No_Select_Statements, N);
2452
2453       --  Loop to analyze alternatives
2454
2455       Alt := First (Alts);
2456       while Present (Alt) loop
2457          Alt_Count := Alt_Count + 1;
2458          Analyze (Alt);
2459
2460          if Nkind (Alt) = N_Delay_Alternative then
2461             if Delay_Present then
2462
2463                if Relative_Present /=
2464                    (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
2465                then
2466                   Error_Msg_N
2467                     ("delay_until and delay_relative alternatives ", Alt);
2468                   Error_Msg_N
2469                     ("\cannot appear in the same selective_wait", Alt);
2470                end if;
2471
2472             else
2473                Delay_Present := True;
2474                Relative_Present :=
2475                  Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
2476             end if;
2477
2478          elsif Nkind (Alt) = N_Terminate_Alternative then
2479             if Terminate_Present then
2480                Error_Msg_N ("only one terminate alternative allowed", N);
2481             else
2482                Terminate_Present := True;
2483                Check_Restriction (No_Terminate_Alternatives, N);
2484             end if;
2485
2486          elsif Nkind (Alt) = N_Accept_Alternative then
2487             Accept_Present := True;
2488
2489             --  Check for duplicate accept
2490
2491             declare
2492                Alt1 : Node_Id;
2493                Stm  : constant Node_Id := Accept_Statement (Alt);
2494                EDN  : constant Node_Id := Entry_Direct_Name (Stm);
2495                Ent  : Entity_Id;
2496
2497             begin
2498                if Nkind (EDN) = N_Identifier
2499                  and then No (Condition (Alt))
2500                  and then Present (Entity (EDN)) -- defend against junk
2501                  and then Ekind (Entity (EDN)) = E_Entry
2502                then
2503                   Ent := Entity (EDN);
2504
2505                   Alt1 := First (Alts);
2506                   while Alt1 /= Alt loop
2507                      if Nkind (Alt1) = N_Accept_Alternative
2508                        and then No (Condition (Alt1))
2509                      then
2510                         declare
2511                            Stm1 : constant Node_Id := Accept_Statement (Alt1);
2512                            EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
2513
2514                         begin
2515                            if Nkind (EDN1) = N_Identifier then
2516                               if Entity (EDN1) = Ent then
2517                                  Error_Msg_Sloc := Sloc (Stm1);
2518                                  Error_Msg_N
2519                                    ("accept duplicates one on line#??", Stm);
2520                                  exit;
2521                               end if;
2522                            end if;
2523                         end;
2524                      end if;
2525
2526                      Next (Alt1);
2527                   end loop;
2528                end if;
2529             end;
2530          end if;
2531
2532          Next (Alt);
2533       end loop;
2534
2535       Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
2536       Check_Potentially_Blocking_Operation (N);
2537
2538       if Terminate_Present and Delay_Present then
2539          Error_Msg_N ("at most one of terminate or delay alternative", N);
2540
2541       elsif not Accept_Present then
2542          Error_Msg_N
2543            ("select must contain at least one accept alternative", N);
2544       end if;
2545
2546       if Present (Else_Statements (N)) then
2547          if Terminate_Present or Delay_Present then
2548             Error_Msg_N ("else part not allowed with other alternatives", N);
2549          end if;
2550
2551          Analyze_Statements (Else_Statements (N));
2552       end if;
2553    end Analyze_Selective_Accept;
2554
2555    ------------------------------------------
2556    -- Analyze_Single_Protected_Declaration --
2557    ------------------------------------------
2558
2559    procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
2560       Loc    : constant Source_Ptr := Sloc (N);
2561       Id     : constant Node_Id    := Defining_Identifier (N);
2562       T      : Entity_Id;
2563       T_Decl : Node_Id;
2564       O_Decl : Node_Id;
2565       O_Name : constant Entity_Id := Id;
2566
2567    begin
2568       Generate_Definition (Id);
2569       Tasking_Used := True;
2570
2571       --  The node is rewritten as a protected type declaration, in exact
2572       --  analogy with what is done with single tasks.
2573
2574       T :=
2575         Make_Defining_Identifier (Sloc (Id),
2576           New_External_Name (Chars (Id), 'T'));
2577
2578       T_Decl :=
2579         Make_Protected_Type_Declaration (Loc,
2580          Defining_Identifier => T,
2581          Protected_Definition => Relocate_Node (Protected_Definition (N)),
2582          Interface_List       => Interface_List (N));
2583
2584       O_Decl :=
2585         Make_Object_Declaration (Loc,
2586           Defining_Identifier => O_Name,
2587           Object_Definition   => Make_Identifier (Loc,  Chars (T)));
2588
2589       Rewrite (N, T_Decl);
2590       Insert_After (N, O_Decl);
2591       Mark_Rewrite_Insertion (O_Decl);
2592
2593       --  Enter names of type and object before analysis, because the name of
2594       --  the object may be used in its own body.
2595
2596       Enter_Name (T);
2597       Set_Ekind (T, E_Protected_Type);
2598       Set_Etype (T, T);
2599
2600       Enter_Name (O_Name);
2601       Set_Ekind (O_Name, E_Variable);
2602       Set_Etype (O_Name, T);
2603
2604       --  Instead of calling Analyze on the new node, call the proper analysis
2605       --  procedure directly. Otherwise the node would be expanded twice, with
2606       --  disastrous result.
2607
2608       Analyze_Protected_Type_Declaration (N);
2609    end Analyze_Single_Protected_Declaration;
2610
2611    -------------------------------------
2612    -- Analyze_Single_Task_Declaration --
2613    -------------------------------------
2614
2615    procedure Analyze_Single_Task_Declaration (N : Node_Id) is
2616       Loc    : constant Source_Ptr := Sloc (N);
2617       Id     : constant Node_Id    := Defining_Identifier (N);
2618       T      : Entity_Id;
2619       T_Decl : Node_Id;
2620       O_Decl : Node_Id;
2621       O_Name : constant Entity_Id := Id;
2622
2623    begin
2624       Generate_Definition (Id);
2625       Tasking_Used := True;
2626
2627       --  The node is rewritten as a task type declaration, followed by an
2628       --  object declaration of that anonymous task type.
2629
2630       T :=
2631         Make_Defining_Identifier (Sloc (Id),
2632           New_External_Name (Chars (Id), Suffix => "TK"));
2633
2634       T_Decl :=
2635         Make_Task_Type_Declaration (Loc,
2636           Defining_Identifier => T,
2637           Task_Definition     => Relocate_Node (Task_Definition (N)),
2638           Interface_List      => Interface_List (N));
2639
2640       --  We use the original defining identifier of the single task in the
2641       --  generated object declaration, so that debugging information can
2642       --  be attached to it when compiling with -gnatD. The parent of the
2643       --  entity is the new object declaration. The single_task_declaration
2644       --  is not used further in semantics or code generation, but is scanned
2645       --  when generating debug information, and therefore needs the updated
2646       --  Sloc information for the entity (see Sprint). Aspect specifications
2647       --  are moved from the single task node to the object declaration node.
2648
2649       O_Decl :=
2650         Make_Object_Declaration (Loc,
2651           Defining_Identifier => O_Name,
2652           Object_Definition   => Make_Identifier (Loc, Chars (T)));
2653
2654       Rewrite (N, T_Decl);
2655       Insert_After (N, O_Decl);
2656       Mark_Rewrite_Insertion (O_Decl);
2657
2658       --  Enter names of type and object before analysis, because the name of
2659       --  the object may be used in its own body.
2660
2661       Enter_Name (T);
2662       Set_Ekind (T, E_Task_Type);
2663       Set_Etype (T, T);
2664
2665       Enter_Name (O_Name);
2666       Set_Ekind (O_Name, E_Variable);
2667       Set_Etype (O_Name, T);
2668
2669       --  Instead of calling Analyze on the new node, call the proper analysis
2670       --  procedure directly. Otherwise the node would be expanded twice, with
2671       --  disastrous result.
2672
2673       Analyze_Task_Type_Declaration (N);
2674
2675       if Has_Aspects (N) then
2676          Analyze_Aspect_Specifications (N, Id);
2677       end if;
2678    end Analyze_Single_Task_Declaration;
2679
2680    -----------------------
2681    -- Analyze_Task_Body --
2682    -----------------------
2683
2684    procedure Analyze_Task_Body (N : Node_Id) is
2685       Body_Id : constant Entity_Id := Defining_Identifier (N);
2686       Decls   : constant List_Id   := Declarations (N);
2687       HSS     : constant Node_Id   := Handled_Statement_Sequence (N);
2688       Last_E  : Entity_Id;
2689
2690       Spec_Id : Entity_Id;
2691       --  This is initially the entity of the task or task type involved, but
2692       --  is replaced by the task type always in the case of a single task
2693       --  declaration, since this is the proper scope to be used.
2694
2695       Ref_Id : Entity_Id;
2696       --  This is the entity of the task or task type, and is the entity used
2697       --  for cross-reference purposes (it differs from Spec_Id in the case of
2698       --  a single task, since Spec_Id is set to the task type).
2699
2700    begin
2701       Tasking_Used := True;
2702       Set_Ekind (Body_Id, E_Task_Body);
2703       Set_Scope (Body_Id, Current_Scope);
2704       Spec_Id := Find_Concurrent_Spec (Body_Id);
2705
2706       --  The spec is either a task type declaration, or a single task
2707       --  declaration for which we have created an anonymous type.
2708
2709       if Present (Spec_Id)
2710         and then Ekind (Spec_Id) = E_Task_Type
2711       then
2712          null;
2713
2714       elsif Present (Spec_Id)
2715         and then Ekind (Etype (Spec_Id)) = E_Task_Type
2716         and then not Comes_From_Source (Etype (Spec_Id))
2717       then
2718          null;
2719
2720       else
2721          Error_Msg_N ("missing specification for task body", Body_Id);
2722          return;
2723       end if;
2724
2725       if Has_Completion (Spec_Id)
2726         and then Present (Corresponding_Body (Parent (Spec_Id)))
2727       then
2728          if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
2729             Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
2730
2731          else
2732             Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
2733          end if;
2734       end if;
2735
2736       Ref_Id := Spec_Id;
2737       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
2738       Style.Check_Identifier (Body_Id, Spec_Id);
2739
2740       --  Deal with case of body of single task (anonymous type was created)
2741
2742       if Ekind (Spec_Id) = E_Variable then
2743          Spec_Id := Etype (Spec_Id);
2744       end if;
2745
2746       Push_Scope (Spec_Id);
2747       Set_Corresponding_Spec (N, Spec_Id);
2748       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
2749       Set_Has_Completion (Spec_Id);
2750       Install_Declarations (Spec_Id);
2751       Last_E := Last_Entity (Spec_Id);
2752
2753       Analyze_Declarations (Decls);
2754       Inspect_Deferred_Constant_Completion (Decls);
2755
2756       --  For visibility purposes, all entities in the body are private. Set
2757       --  First_Private_Entity accordingly, if there was no private part in the
2758       --  protected declaration.
2759
2760       if No (First_Private_Entity (Spec_Id)) then
2761          if Present (Last_E) then
2762             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
2763          else
2764             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
2765          end if;
2766       end if;
2767
2768       --  Mark all handlers as not suitable for local raise optimization,
2769       --  since this optimization causes difficulties in a task context.
2770
2771       if Present (Exception_Handlers (HSS)) then
2772          declare
2773             Handlr : Node_Id;
2774          begin
2775             Handlr := First (Exception_Handlers (HSS));
2776             while Present (Handlr) loop
2777                Set_Local_Raise_Not_OK (Handlr);
2778                Next (Handlr);
2779             end loop;
2780          end;
2781       end if;
2782
2783       --  Now go ahead and complete analysis of the task body
2784
2785       Analyze (HSS);
2786       Check_Completion (Body_Id);
2787       Check_References (Body_Id);
2788       Check_References (Spec_Id);
2789
2790       --  Check for entries with no corresponding accept
2791
2792       declare
2793          Ent : Entity_Id;
2794
2795       begin
2796          Ent := First_Entity (Spec_Id);
2797          while Present (Ent) loop
2798             if Is_Entry (Ent)
2799               and then not Entry_Accepted (Ent)
2800               and then Comes_From_Source (Ent)
2801             then
2802                Error_Msg_NE ("no accept for entry &??", N, Ent);
2803             end if;
2804
2805             Next_Entity (Ent);
2806          end loop;
2807       end;
2808
2809       Process_End_Label (HSS, 't', Ref_Id);
2810       End_Scope;
2811    end Analyze_Task_Body;
2812
2813    -----------------------------
2814    -- Analyze_Task_Definition --
2815    -----------------------------
2816
2817    procedure Analyze_Task_Definition (N : Node_Id) is
2818       L : Entity_Id;
2819
2820    begin
2821       Tasking_Used := True;
2822       Check_SPARK_Restriction ("task definition is not allowed", N);
2823
2824       if Present (Visible_Declarations (N)) then
2825          Analyze_Declarations (Visible_Declarations (N));
2826       end if;
2827
2828       if Present (Private_Declarations (N)) then
2829          L := Last_Entity (Current_Scope);
2830          Analyze_Declarations (Private_Declarations (N));
2831
2832          if Present (L) then
2833             Set_First_Private_Entity
2834               (Current_Scope, Next_Entity (L));
2835          else
2836             Set_First_Private_Entity
2837               (Current_Scope, First_Entity (Current_Scope));
2838          end if;
2839       end if;
2840
2841       Check_Max_Entries (N, Max_Task_Entries);
2842       Process_End_Label (N, 'e', Current_Scope);
2843    end Analyze_Task_Definition;
2844
2845    -----------------------------------
2846    -- Analyze_Task_Type_Declaration --
2847    -----------------------------------
2848
2849    procedure Analyze_Task_Type_Declaration (N : Node_Id) is
2850       Def_Id : constant Entity_Id := Defining_Identifier (N);
2851       T      : Entity_Id;
2852
2853    begin
2854       Check_Restriction (No_Tasking, N);
2855       Tasking_Used := True;
2856       T := Find_Type_Name (N);
2857       Generate_Definition (T);
2858
2859       --  In the case of an incomplete type, use the full view, unless it's not
2860       --  present (as can occur for an incomplete view from a limited with).
2861       --  Initialize the Corresponding_Record_Type (which overlays the Private
2862       --  Dependents field of the incomplete view).
2863
2864       if Ekind (T) = E_Incomplete_Type then
2865          if Present (Full_View (T)) then
2866             T := Full_View (T);
2867             Set_Completion_Referenced (T);
2868
2869          else
2870             Set_Ekind (T, E_Task_Type);
2871             Set_Corresponding_Record_Type (T, Empty);
2872          end if;
2873       end if;
2874
2875       Set_Ekind              (T, E_Task_Type);
2876       Set_Is_First_Subtype   (T, True);
2877       Set_Has_Task           (T, True);
2878       Init_Size_Align        (T);
2879       Set_Etype              (T, T);
2880       Set_Has_Delayed_Freeze (T, True);
2881       Set_Stored_Constraint  (T, No_Elist);
2882       Push_Scope (T);
2883
2884       if Ada_Version >= Ada_2005 then
2885          Check_Interfaces (N, T);
2886       end if;
2887
2888       if Present (Discriminant_Specifications (N)) then
2889          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2890             Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
2891          end if;
2892
2893          if Has_Discriminants (T) then
2894
2895             --  Install discriminants. Also, verify conformance of
2896             --  discriminants of previous and current view. ???
2897
2898             Install_Declarations (T);
2899          else
2900             Process_Discriminants (N);
2901          end if;
2902       end if;
2903
2904       Set_Is_Constrained (T, not Has_Discriminants (T));
2905
2906       if Has_Aspects (N) then
2907          Analyze_Aspect_Specifications (N, Def_Id);
2908       end if;
2909
2910       if Present (Task_Definition (N)) then
2911          Analyze_Task_Definition (Task_Definition (N));
2912       end if;
2913
2914       --  In the case where the task type is declared at a nested level and the
2915       --  No_Task_Hierarchy restriction applies, issue a warning that objects
2916       --  of the type will violate the restriction.
2917
2918       if Restriction_Check_Required (No_Task_Hierarchy)
2919         and then not Is_Library_Level_Entity (T)
2920         and then Comes_From_Source (T)
2921       then
2922          Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
2923
2924          if Error_Msg_Sloc = No_Location then
2925             Error_Msg_N
2926               ("objects of this type will violate `No_Task_Hierarchy`??", N);
2927          else
2928             Error_Msg_N
2929               ("objects of this type will violate `No_Task_Hierarchy`#??", N);
2930          end if;
2931       end if;
2932
2933       End_Scope;
2934
2935       --  Case of a completion of a private declaration
2936
2937       if T /= Def_Id
2938         and then Is_Private_Type (Def_Id)
2939       then
2940          --  Deal with preelaborable initialization. Note that this processing
2941          --  is done by Process_Full_View, but as can be seen below, in this
2942          --  case the call to Process_Full_View is skipped if any serious
2943          --  errors have occurred, and we don't want to lose this check.
2944
2945          if Known_To_Have_Preelab_Init (Def_Id) then
2946             Set_Must_Have_Preelab_Init (T);
2947          end if;
2948
2949          --  Create corresponding record now, because some private dependents
2950          --  may be subtypes of the partial view.
2951
2952          --  Skip if errors are present, to prevent cascaded messages
2953
2954          if Serious_Errors_Detected = 0
2955
2956            --  Also skip if expander is not active
2957
2958            and then Full_Expander_Active
2959          then
2960             Expand_N_Task_Type_Declaration (N);
2961             Process_Full_View (N, T, Def_Id);
2962          end if;
2963       end if;
2964    end Analyze_Task_Type_Declaration;
2965
2966    -----------------------------------
2967    -- Analyze_Terminate_Alternative --
2968    -----------------------------------
2969
2970    procedure Analyze_Terminate_Alternative (N : Node_Id) is
2971    begin
2972       Tasking_Used := True;
2973
2974       if Present (Pragmas_Before (N)) then
2975          Analyze_List (Pragmas_Before (N));
2976       end if;
2977
2978       if Present (Condition (N)) then
2979          Analyze_And_Resolve (Condition (N), Any_Boolean);
2980       end if;
2981    end Analyze_Terminate_Alternative;
2982
2983    ------------------------------
2984    -- Analyze_Timed_Entry_Call --
2985    ------------------------------
2986
2987    procedure Analyze_Timed_Entry_Call (N : Node_Id) is
2988       Trigger        : constant Node_Id :=
2989                          Entry_Call_Statement (Entry_Call_Alternative (N));
2990       Is_Disp_Select : Boolean := False;
2991
2992    begin
2993       Tasking_Used := True;
2994       Check_SPARK_Restriction ("select statement is not allowed", N);
2995       Check_Restriction (No_Select_Statements, N);
2996
2997       --  Ada 2005 (AI-345): The trigger may be a dispatching call
2998
2999       if Ada_Version >= Ada_2005 then
3000          Analyze (Trigger);
3001          Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
3002       end if;
3003
3004       --  Postpone the analysis of the statements till expansion. Analyze only
3005       --  if the expander is disabled in order to catch any semantic errors.
3006
3007       if Is_Disp_Select then
3008          if not Expander_Active then
3009             Analyze (Entry_Call_Alternative (N));
3010             Analyze (Delay_Alternative (N));
3011          end if;
3012
3013       --  Regular select analysis
3014
3015       else
3016          Analyze (Entry_Call_Alternative (N));
3017          Analyze (Delay_Alternative (N));
3018       end if;
3019    end Analyze_Timed_Entry_Call;
3020
3021    ------------------------------------
3022    -- Analyze_Triggering_Alternative --
3023    ------------------------------------
3024
3025    procedure Analyze_Triggering_Alternative (N : Node_Id) is
3026       Trigger : constant Node_Id := Triggering_Statement (N);
3027
3028    begin
3029       Tasking_Used := True;
3030
3031       if Present (Pragmas_Before (N)) then
3032          Analyze_List (Pragmas_Before (N));
3033       end if;
3034
3035       Analyze (Trigger);
3036
3037       if Comes_From_Source (Trigger)
3038         and then Nkind (Trigger) not in N_Delay_Statement
3039         and then Nkind (Trigger) /= N_Entry_Call_Statement
3040       then
3041          if Ada_Version < Ada_2005 then
3042             Error_Msg_N
3043              ("triggering statement must be delay or entry call", Trigger);
3044
3045          --  Ada 2005 (AI-345): If a procedure_call_statement is used for a
3046          --  procedure_or_entry_call, the procedure_name or procedure_prefix
3047          --  of the procedure_call_statement shall denote an entry renamed by a
3048          --  procedure, or (a view of) a primitive subprogram of a limited
3049          --  interface whose first parameter is a controlling parameter.
3050
3051          elsif Nkind (Trigger) = N_Procedure_Call_Statement
3052            and then not Is_Renamed_Entry (Entity (Name (Trigger)))
3053            and then not Is_Controlling_Limited_Procedure
3054                           (Entity (Name (Trigger)))
3055          then
3056             Error_Msg_N ("triggering statement must be delay, procedure " &
3057                          "or entry call", Trigger);
3058          end if;
3059       end if;
3060
3061       if Is_Non_Empty_List (Statements (N)) then
3062          Analyze_Statements (Statements (N));
3063       end if;
3064    end Analyze_Triggering_Alternative;
3065
3066    -----------------------
3067    -- Check_Max_Entries --
3068    -----------------------
3069
3070    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
3071       Ecount : Uint;
3072
3073       procedure Count (L : List_Id);
3074       --  Count entries in given declaration list
3075
3076       -----------
3077       -- Count --
3078       -----------
3079
3080       procedure Count (L : List_Id) is
3081          D : Node_Id;
3082
3083       begin
3084          if No (L) then
3085             return;
3086          end if;
3087
3088          D := First (L);
3089          while Present (D) loop
3090             if Nkind (D) = N_Entry_Declaration then
3091                declare
3092                   DSD : constant Node_Id :=
3093                           Discrete_Subtype_Definition (D);
3094
3095                begin
3096                   --  If not an entry family, then just one entry
3097
3098                   if No (DSD) then
3099                      Ecount := Ecount + 1;
3100
3101                   --  If entry family with static bounds, count entries
3102
3103                   elsif Is_OK_Static_Subtype (Etype (DSD)) then
3104                      declare
3105                         Lo : constant Uint :=
3106                                Expr_Value
3107                                  (Type_Low_Bound (Etype (DSD)));
3108                         Hi : constant Uint :=
3109                                Expr_Value
3110                                  (Type_High_Bound (Etype (DSD)));
3111
3112                      begin
3113                         if Hi >= Lo then
3114                            Ecount := Ecount + Hi - Lo + 1;
3115                         end if;
3116                      end;
3117
3118                   --  Entry family with non-static bounds
3119
3120                   else
3121                      --  Record an unknown count restriction, and if the
3122                      --  restriction is active, post a message or warning.
3123
3124                      Check_Restriction (R, D);
3125                   end if;
3126                end;
3127             end if;
3128
3129             Next (D);
3130          end loop;
3131       end Count;
3132
3133    --  Start of processing for Check_Max_Entries
3134
3135    begin
3136       Ecount := Uint_0;
3137       Count (Visible_Declarations (D));
3138       Count (Private_Declarations (D));
3139
3140       if Ecount > 0 then
3141          Check_Restriction (R, D, Ecount);
3142       end if;
3143    end Check_Max_Entries;
3144
3145    ----------------------
3146    -- Check_Interfaces --
3147    ----------------------
3148
3149    procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
3150       Iface     : Node_Id;
3151       Iface_Typ : Entity_Id;
3152
3153    begin
3154       pragma Assert
3155         (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
3156
3157       if Present (Interface_List (N)) then
3158          Set_Is_Tagged_Type (T);
3159
3160          Iface := First (Interface_List (N));
3161          while Present (Iface) loop
3162             Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
3163
3164             if not Is_Interface (Iface_Typ) then
3165                Error_Msg_NE
3166                  ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
3167
3168             else
3169                --  Ada 2005 (AI-251): "The declaration of a specific descendant
3170                --  of an interface type freezes the interface type" RM 13.14.
3171
3172                Freeze_Before (N, Etype (Iface));
3173
3174                if Nkind (N) = N_Protected_Type_Declaration then
3175
3176                   --  Ada 2005 (AI-345): Protected types can only implement
3177                   --  limited, synchronized, or protected interfaces (note that
3178                   --  the predicate Is_Limited_Interface includes synchronized
3179                   --  and protected interfaces).
3180
3181                   if Is_Task_Interface (Iface_Typ) then
3182                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
3183                        & "a task interface", Iface);
3184
3185                   elsif not Is_Limited_Interface (Iface_Typ) then
3186                      Error_Msg_N ("(Ada 2005) protected type cannot implement "
3187                        & "a non-limited interface", Iface);
3188                   end if;
3189
3190                else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
3191
3192                   --  Ada 2005 (AI-345): Task types can only implement limited,
3193                   --  synchronized, or task interfaces (note that the predicate
3194                   --  Is_Limited_Interface includes synchronized and task
3195                   --  interfaces).
3196
3197                   if Is_Protected_Interface (Iface_Typ) then
3198                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3199                        "protected interface", Iface);
3200
3201                   elsif not Is_Limited_Interface (Iface_Typ) then
3202                      Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3203                        "non-limited interface", Iface);
3204                   end if;
3205                end if;
3206             end if;
3207
3208             Next (Iface);
3209          end loop;
3210       end if;
3211
3212       if not Has_Private_Declaration (T) then
3213          return;
3214       end if;
3215
3216       --  Additional checks on full-types associated with private type
3217       --  declarations. Search for the private type declaration.
3218
3219       declare
3220          Full_T_Ifaces : Elist_Id;
3221          Iface         : Node_Id;
3222          Priv_T        : Entity_Id;
3223          Priv_T_Ifaces : Elist_Id;
3224
3225       begin
3226          Priv_T := First_Entity (Scope (T));
3227          loop
3228             pragma Assert (Present (Priv_T));
3229
3230             if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
3231                exit when Full_View (Priv_T) = T;
3232             end if;
3233
3234             Next_Entity (Priv_T);
3235          end loop;
3236
3237          --  In case of synchronized types covering interfaces the private type
3238          --  declaration must be limited.
3239
3240          if Present (Interface_List (N))
3241            and then not Is_Limited_Type (Priv_T)
3242          then
3243             Error_Msg_Sloc := Sloc (Priv_T);
3244             Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
3245                          "private type#", T);
3246          end if;
3247
3248          --  RM 7.3 (7.1/2): If the full view has a partial view that is
3249          --  tagged then check RM 7.3 subsidiary rules.
3250
3251          if Is_Tagged_Type (Priv_T)
3252            and then not Error_Posted (N)
3253          then
3254             --  RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
3255             --  type if and only if the full type is a synchronized tagged type
3256
3257             if Is_Synchronized_Tagged_Type (Priv_T)
3258               and then not Is_Synchronized_Tagged_Type (T)
3259             then
3260                Error_Msg_N
3261                  ("(Ada 2005) full view must be a synchronized tagged " &
3262                   "type (RM 7.3 (7.2/2))", Priv_T);
3263
3264             elsif Is_Synchronized_Tagged_Type (T)
3265               and then not Is_Synchronized_Tagged_Type (Priv_T)
3266             then
3267                Error_Msg_N
3268                  ("(Ada 2005) partial view must be a synchronized tagged " &
3269                   "type (RM 7.3 (7.2/2))", T);
3270             end if;
3271
3272             --  RM 7.3 (7.3/2): The partial view shall be a descendant of an
3273             --  interface type if and only if the full type is descendant of
3274             --  the interface type.
3275
3276             if Present (Interface_List (N))
3277               or else (Is_Tagged_Type (Priv_T)
3278                          and then Has_Interfaces
3279                                    (Priv_T, Use_Full_View => False))
3280             then
3281                if Is_Tagged_Type (Priv_T) then
3282                   Collect_Interfaces
3283                     (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
3284                end if;
3285
3286                if Is_Tagged_Type (T) then
3287                   Collect_Interfaces (T, Full_T_Ifaces);
3288                end if;
3289
3290                Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
3291
3292                if Present (Iface) then
3293                   Error_Msg_NE
3294                     ("interface & not implemented by full type " &
3295                      "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
3296                end if;
3297
3298                Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
3299
3300                if Present (Iface) then
3301                   Error_Msg_NE
3302                     ("interface & not implemented by partial " &
3303                      "view (RM-2005 7.3 (7.3/2))", T, Iface);
3304                end if;
3305             end if;
3306          end if;
3307       end;
3308    end Check_Interfaces;
3309
3310    --------------------------------
3311    -- Check_Triggering_Statement --
3312    --------------------------------
3313
3314    procedure Check_Triggering_Statement
3315      (Trigger        : Node_Id;
3316       Error_Node     : Node_Id;
3317       Is_Dispatching : out Boolean)
3318    is
3319       Param : Node_Id;
3320
3321    begin
3322       Is_Dispatching := False;
3323
3324       --  It is not possible to have a dispatching trigger if we are not in
3325       --  Ada 2005 mode.
3326
3327       if Ada_Version >= Ada_2005
3328         and then Nkind (Trigger) = N_Procedure_Call_Statement
3329         and then Present (Parameter_Associations (Trigger))
3330       then
3331          Param := First (Parameter_Associations (Trigger));
3332
3333          if Is_Controlling_Actual (Param)
3334            and then Is_Interface (Etype (Param))
3335          then
3336             if Is_Limited_Record (Etype (Param)) then
3337                Is_Dispatching := True;
3338             else
3339                Error_Msg_N
3340                  ("dispatching operation of limited or synchronized " &
3341                   "interface required (RM 9.7.2(3))!", Error_Node);
3342             end if;
3343
3344          elsif Nkind (Trigger) = N_Explicit_Dereference then
3345             Error_Msg_N
3346               ("entry call or dispatching primitive of interface required ",
3347                 Trigger);
3348          end if;
3349       end if;
3350    end Check_Triggering_Statement;
3351
3352    --------------------------
3353    -- Find_Concurrent_Spec --
3354    --------------------------
3355
3356    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
3357       Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
3358
3359    begin
3360       --  The type may have been given by an incomplete type declaration.
3361       --  Find full view now.
3362
3363       if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
3364          Spec_Id := Full_View (Spec_Id);
3365       end if;
3366
3367       return Spec_Id;
3368    end Find_Concurrent_Spec;
3369
3370    --------------------------
3371    -- Install_Declarations --
3372    --------------------------
3373
3374    procedure Install_Declarations (Spec : Entity_Id) is
3375       E    : Entity_Id;
3376       Prev : Entity_Id;
3377    begin
3378       E := First_Entity (Spec);
3379       while Present (E) loop
3380          Prev := Current_Entity (E);
3381          Set_Current_Entity (E);
3382          Set_Is_Immediately_Visible (E);
3383          Set_Homonym (E, Prev);
3384          Next_Entity (E);
3385       end loop;
3386    end Install_Declarations;
3387
3388    ---------------------------
3389    -- Install_Discriminants --
3390    ---------------------------
3391
3392    procedure Install_Discriminants (E : Entity_Id) is
3393       Disc : Entity_Id;
3394       Prev : Entity_Id;
3395    begin
3396       Disc := First_Discriminant (E);
3397       while Present (Disc) loop
3398          Prev := Current_Entity (Disc);
3399          Set_Current_Entity (Disc);
3400          Set_Is_Immediately_Visible (Disc);
3401          Set_Homonym (Disc, Prev);
3402          Next_Discriminant (Disc);
3403       end loop;
3404    end Install_Discriminants;
3405
3406    ------------------------------------------
3407    -- Push_Scope_And_Install_Discriminants --
3408    ------------------------------------------
3409
3410    procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is
3411    begin
3412       if Has_Discriminants (E) then
3413          Push_Scope (E);
3414          Install_Discriminants (E);
3415       end if;
3416    end Push_Scope_And_Install_Discriminants;
3417
3418    -----------------------------
3419    -- Uninstall_Discriminants --
3420    -----------------------------
3421
3422    procedure Uninstall_Discriminants (E : Entity_Id) is
3423       Disc  : Entity_Id;
3424       Prev  : Entity_Id;
3425       Outer : Entity_Id;
3426
3427    begin
3428       Disc := First_Discriminant (E);
3429       while Present (Disc) loop
3430          if Disc /= Current_Entity (Disc) then
3431             Prev := Current_Entity (Disc);
3432             while Present (Prev)
3433               and then Present (Homonym (Prev))
3434               and then Homonym (Prev) /= Disc
3435             loop
3436                Prev := Homonym (Prev);
3437             end loop;
3438          else
3439             Prev := Empty;
3440          end if;
3441
3442          Set_Is_Immediately_Visible (Disc, False);
3443
3444          Outer := Homonym (Disc);
3445          while Present (Outer) and then Scope (Outer) = E loop
3446             Outer := Homonym (Outer);
3447          end loop;
3448
3449          --  Reset homonym link of other entities, but do not modify link
3450          --  between entities in current scope, so that the back-end can have
3451          --  a proper count of local overloadings.
3452
3453          if No (Prev) then
3454             Set_Name_Entity_Id (Chars (Disc), Outer);
3455
3456          elsif Scope (Prev) /= Scope (Disc) then
3457             Set_Homonym (Prev,  Outer);
3458          end if;
3459
3460          Next_Discriminant (Disc);
3461       end loop;
3462    end Uninstall_Discriminants;
3463
3464    -------------------------------------------
3465    -- Uninstall_Discriminants_And_Pop_Scope --
3466    -------------------------------------------
3467
3468    procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is
3469    begin
3470       if Has_Discriminants (E) then
3471          Uninstall_Discriminants (E);
3472          Pop_Scope;
3473       end if;
3474    end Uninstall_Discriminants_And_Pop_Scope;
3475 end Sem_Ch9;