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