gcc/ada/sem_ch11.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ C H 1 1                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Lib;      use Lib;
  32 with Lib.Xref; use Lib.Xref;
  33 with Namet;    use Namet;
  34 with Nlists;   use Nlists;
  35 with Nmake;    use Nmake;
  36 with Opt;      use Opt;
  37 with Restrict; use Restrict;
  38 with Rident;   use Rident;
  39 with Rtsfind;  use Rtsfind;
  40 with Sem;      use Sem;
  41 with Sem_Ch5;  use Sem_Ch5;
  42 with Sem_Ch8;  use Sem_Ch8;
  43 with Sem_Ch13; use Sem_Ch13;
  44 with Sem_Res;  use Sem_Res;
  45 with Sem_Util; use Sem_Util;
  46 with Sem_Warn; use Sem_Warn;
  47 with Sinfo;    use Sinfo;
  48 with Stand;    use Stand;
  49 with Uintp;    use Uintp;
  50
  51 package body Sem_Ch11 is
  52
  53    -----------------------------------
  54    -- Analyze_Exception_Declaration --
  55    -----------------------------------
  56
  57    procedure Analyze_Exception_Declaration (N : Node_Id) is
  58       Id : constant Entity_Id := Defining_Identifier (N);
  59       PF : constant Boolean   := Is_Pure (Current_Scope);
  60    begin
  61       Generate_Definition         (Id);
  62       Enter_Name                  (Id);
  63       Set_Ekind                   (Id, E_Exception);
  64       Set_Exception_Code          (Id, Uint_0);
  65       Set_Etype                   (Id, Standard_Exception_Type);
  66       Set_Is_Statically_Allocated (Id);
  67       Set_Is_Pure                 (Id, PF);
  68       Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
  69    end Analyze_Exception_Declaration;
  70
  71    --------------------------------
  72    -- Analyze_Exception_Handlers --
  73    --------------------------------
  74
  75    procedure Analyze_Exception_Handlers (L : List_Id) is
  76       Handler : Node_Id;
  77       Choice  : Entity_Id;
  78       Id      : Node_Id;
  79       H_Scope : Entity_Id := Empty;
  80
  81       procedure Check_Duplication (Id : Node_Id);
  82       --  Iterate through the identifiers in each handler to find duplicates
  83
  84       function Others_Present return Boolean;
  85       --  Returns True if others handler is present
  86
  87       -----------------------
  88       -- Check_Duplication --
  89       -----------------------
  90
  91       procedure Check_Duplication (Id : Node_Id) is
  92          Handler   : Node_Id;
  93          Id1       : Node_Id;
  94          Id_Entity : Entity_Id := Entity (Id);
  95
  96       begin
  97          if Present (Renamed_Entity (Id_Entity)) then
  98             Id_Entity := Renamed_Entity (Id_Entity);
  99          end if;
 100
 101          Handler := First_Non_Pragma (L);
 102          while Present (Handler) loop
 103             Id1 := First (Exception_Choices (Handler));
 104             while Present (Id1) loop
 105
 106                --  Only check against the exception choices which precede
 107                --  Id in the handler, since the ones that follow Id have not
 108                --  been analyzed yet and will be checked in a subsequent call.
 109
 110                if Id = Id1 then
 111                   return;
 112
 113                elsif Nkind (Id1) /= N_Others_Choice
 114                  and then
 115                    (Id_Entity = Entity (Id1)
 116                       or else (Id_Entity = Renamed_Entity (Entity (Id1))))
 117                then
 118                   if Handler /= Parent (Id) then
 119                      Error_Msg_Sloc := Sloc (Id1);
 120                      Error_Msg_NE
 121                        ("exception choice duplicates &#", Id, Id1);
 122
 123                   else
 124                      if Ada_Version = Ada_83
 125                        and then Comes_From_Source (Id)
 126                      then
 127                         Error_Msg_N
 128                           ("(Ada 83): duplicate exception choice&", Id);
 129                      end if;
 130                   end if;
 131                end if;
 132
 133                Next_Non_Pragma (Id1);
 134             end loop;
 135
 136             Next (Handler);
 137          end loop;
 138       end Check_Duplication;
 139
 140       --------------------
 141       -- Others_Present --
 142       --------------------
 143
 144       function Others_Present return Boolean is
 145          H : Node_Id;
 146
 147       begin
 148          H := First (L);
 149          while Present (H) loop
 150             if Nkind (H) /= N_Pragma
 151               and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
 152             then
 153                return True;
 154             end if;
 155
 156             Next (H);
 157          end loop;
 158
 159          return False;
 160       end Others_Present;
 161
 162    --  Start of processing for Analyze_Exception_Handlers
 163
 164    begin
 165       Handler := First (L);
 166       Check_Restriction (No_Exceptions, Handler);
 167       Check_Restriction (No_Exception_Handlers, Handler);
 168
 169       --  Kill current remembered values, since we don't know where we were
 170       --  when the exception was raised.
 171
 172       Kill_Current_Values;
 173
 174       --  Loop through handlers (which can include pragmas)
 175
 176       while Present (Handler) loop
 177
 178          --  If pragma just analyze it
 179
 180          if Nkind (Handler) = N_Pragma then
 181             Analyze (Handler);
 182
 183          --  Otherwise we have a real exception handler
 184
 185          else
 186             --  Deal with choice parameter. The exception handler is a
 187             --  declarative part for the choice parameter, so it constitutes a
 188             --  scope for visibility purposes. We create an entity to denote
 189             --  the whole exception part, and use it as the scope of all the
 190             --  choices, which may even have the same name without conflict.
 191             --  This scope plays no other role in expansion or code generation.
 192
 193             Choice := Choice_Parameter (Handler);
 194
 195             if Present (Choice) then
 196                Set_Local_Raise_Not_OK (Handler);
 197
 198                if Comes_From_Source (Choice) then
 199                   Check_Restriction (No_Exception_Propagation, Choice);
 200                end if;
 201
 202                if No (H_Scope) then
 203                   H_Scope :=
 204                     New_Internal_Entity
 205                      (E_Block, Current_Scope, Sloc (Choice), 'E');
 206                end if;
 207
 208                Push_Scope (H_Scope);
 209                Set_Etype (H_Scope, Standard_Void_Type);
 210
 211                --  Set the Finalization Chain entity to Error means that it
 212                --  should not be used at that level but the parent one should
 213                --  be used instead.
 214
 215                --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
 216                --  ??? using Error for this non-error condition is nasty ???
 217
 218                Set_Finalization_Chain_Entity (H_Scope, Error);
 219
 220                Enter_Name (Choice);
 221                Set_Ekind (Choice, E_Variable);
 222
 223                if RTE_Available (RE_Exception_Occurrence) then
 224                   Set_Etype (Choice, RTE (RE_Exception_Occurrence));
 225                end if;
 226
 227                Generate_Definition (Choice);
 228
 229                --  Indicate that choice has an initial value, since in effect
 230                --  this field is assigned an initial value by the exception.
 231                --  We also consider that it is modified in the source.
 232
 233                Set_Has_Initial_Value (Choice, True);
 234                Set_Never_Set_In_Source (Choice, False);
 235             end if;
 236
 237             Id := First (Exception_Choices (Handler));
 238             while Present (Id) loop
 239                if Nkind (Id) = N_Others_Choice then
 240                   if Present (Next (Id))
 241                     or else Present (Next (Handler))
 242                     or else Present (Prev (Id))
 243                   then
 244                      Error_Msg_N ("OTHERS must appear alone and last", Id);
 245                   end if;
 246
 247                else
 248                   Analyze (Id);
 249
 250                   --  In most cases the choice has already been analyzed in
 251                   --  Analyze_Handled_Statement_Sequence, in order to expand
 252                   --  local handlers. This advance analysis does not take into
 253                   --  account the case in which a choice has the same name as
 254                   --  the choice parameter of the handler, which may hide an
 255                   --  outer exception. This pathological case appears in ACATS
 256                   --  B80001_3.adb, and requires an explicit check to verify
 257                   --  that the id is not hidden.
 258
 259                   if not Is_Entity_Name (Id)
 260                     or else Ekind (Entity (Id)) /= E_Exception
 261                     or else
 262                       (Nkind (Id) = N_Identifier
 263                         and then Chars (Id) = Chars (Choice))
 264                   then
 265                      Error_Msg_N ("exception name expected", Id);
 266
 267                   else
 268                      --  Emit a warning at the declaration level when a local
 269                      --  exception is never raised explicitly.
 270
 271                      if Warn_On_Redundant_Constructs
 272                        and then not Is_Raised (Entity (Id))
 273                        and then Scope (Entity (Id)) = Current_Scope
 274                      then
 275                         Error_Msg_NE
 276                           ("?exception & is never raised", Entity (Id), Id);
 277                      end if;
 278
 279                      if Present (Renamed_Entity (Entity (Id))) then
 280                         if Entity (Id) = Standard_Numeric_Error then
 281                            Check_Restriction (No_Obsolescent_Features, Id);
 282
 283                            if Warn_On_Obsolescent_Feature then
 284                               Error_Msg_N
 285                                 ("Numeric_Error is an " &
 286                                  "obsolescent feature (RM J.6(1))?", Id);
 287                               Error_Msg_N
 288                                 ("\use Constraint_Error instead?", Id);
 289                            end if;
 290                         end if;
 291                      end if;
 292
 293                      Check_Duplication (Id);
 294
 295                      --  Check for exception declared within generic formal
 296                      --  package (which is illegal, see RM 11.2(8))
 297
 298                      declare
 299                         Ent  : Entity_Id := Entity (Id);
 300                         Scop : Entity_Id;
 301
 302                      begin
 303                         if Present (Renamed_Entity (Ent)) then
 304                            Ent := Renamed_Entity (Ent);
 305                         end if;
 306
 307                         Scop := Scope (Ent);
 308                         while Scop /= Standard_Standard
 309                           and then Ekind (Scop) = E_Package
 310                         loop
 311                            if Nkind (Declaration_Node (Scop)) =
 312                                            N_Package_Specification
 313                              and then
 314                                Nkind (Original_Node (Parent
 315                                  (Declaration_Node (Scop)))) =
 316                                            N_Formal_Package_Declaration
 317                            then
 318                               Error_Msg_NE
 319                                 ("exception& is declared in "  &
 320                                  "generic formal package", Id, Ent);
 321                               Error_Msg_N
 322                                 ("\and therefore cannot appear in " &
 323                                  "handler (RM 11.2(8))", Id);
 324                               exit;
 325
 326                            --  If the exception is declared in an inner
 327                            --  instance, nothing else to check.
 328
 329                            elsif Is_Generic_Instance (Scop) then
 330                               exit;
 331                            end if;
 332
 333                            Scop := Scope (Scop);
 334                         end loop;
 335                      end;
 336                   end if;
 337                end if;
 338
 339                Next (Id);
 340             end loop;
 341
 342             --  Check for redundant handler (has only raise statement) and is
 343             --  either an others handler, or is a specific handler when no
 344             --  others handler is present.
 345
 346             if Warn_On_Redundant_Constructs
 347               and then List_Length (Statements (Handler)) = 1
 348               and then Nkind (First (Statements (Handler))) = N_Raise_Statement
 349               and then No (Name (First (Statements (Handler))))
 350               and then (not Others_Present
 351                           or else Nkind (First (Exception_Choices (Handler))) =
 352                                               N_Others_Choice)
 353             then
 354                Error_Msg_N
 355                  ("useless handler contains only a reraise statement?",
 356                   Handler);
 357             end if;
 358
 359             --  Now analyze the statements of this handler
 360
 361             Analyze_Statements (Statements (Handler));
 362
 363             --  If a choice was present, we created a special scope for it,
 364             --  so this is where we pop that special scope to get rid of it.
 365
 366             if Present (Choice) then
 367                End_Scope;
 368             end if;
 369          end if;
 370
 371          Next (Handler);
 372       end loop;
 373    end Analyze_Exception_Handlers;
 374
 375    --------------------------------
 376    -- Analyze_Handled_Statements --
 377    --------------------------------
 378
 379    procedure Analyze_Handled_Statements (N : Node_Id) is
 380       Handlers : constant List_Id := Exception_Handlers (N);
 381       Handler  : Node_Id;
 382       Choice   : Node_Id;
 383
 384    begin
 385       if Present (Handlers) then
 386          Kill_All_Checks;
 387       end if;
 388
 389       --  We are now going to analyze the statements and then the exception
 390       --  handlers. We certainly need to do things in this order to get the
 391       --  proper sequential semantics for various warnings.
 392
 393       --  However, there is a glitch. When we process raise statements, an
 394       --  optimization is to look for local handlers and specialize the code
 395       --  in this case.
 396
 397       --  In order to detect if a handler is matching, we must have at least
 398       --  analyzed the choices in the proper scope so that proper visibility
 399       --  analysis is performed. Hence we analyze just the choices first,
 400       --  before we analyze the statement sequence.
 401
 402       Handler := First_Non_Pragma (Handlers);
 403       while Present (Handler) loop
 404          Choice := First_Non_Pragma (Exception_Choices (Handler));
 405          while Present (Choice) loop
 406             Analyze (Choice);
 407             Next_Non_Pragma (Choice);
 408          end loop;
 409
 410          Next_Non_Pragma (Handler);
 411       end loop;
 412
 413       --  Analyze statements in sequence
 414
 415       Analyze_Statements (Statements (N));
 416
 417       --  If the current scope is a subprogram, then this is the right place to
 418       --  check for hanging useless assignments from the statement sequence of
 419       --  the subprogram body.
 420
 421       if Is_Subprogram (Current_Scope) then
 422          Warn_On_Useless_Assignments (Current_Scope);
 423       end if;
 424
 425       --  Deal with handlers or AT END proc
 426
 427       if Present (Handlers) then
 428          Analyze_Exception_Handlers (Handlers);
 429       elsif Present (At_End_Proc (N)) then
 430          Analyze (At_End_Proc (N));
 431       end if;
 432    end Analyze_Handled_Statements;
 433
 434    -----------------------------
 435    -- Analyze_Raise_Statement --
 436    -----------------------------
 437
 438    procedure Analyze_Raise_Statement (N : Node_Id) is
 439       Exception_Id   : constant Node_Id := Name (N);
 440       Exception_Name : Entity_Id        := Empty;
 441       P              : Node_Id;
 442
 443    begin
 444       Check_Unreachable_Code (N);
 445
 446       --  Check exception restrictions on the original source
 447
 448       if Comes_From_Source (N) then
 449          Check_Restriction (No_Exceptions, N);
 450       end if;
 451
 452       --  Check for useless assignment to OUT or IN OUT scalar immediately
 453       --  preceding the raise. Right now we only look at assignment statements,
 454       --  we could do more.
 455
 456       if Is_List_Member (N) then
 457          declare
 458             P : Node_Id;
 459             L : Node_Id;
 460
 461          begin
 462             P := Prev (N);
 463
 464             if Present (P)
 465               and then Nkind (P) = N_Assignment_Statement
 466             then
 467                L := Name (P);
 468
 469                if Is_Scalar_Type (Etype (L))
 470                  and then Is_Entity_Name (L)
 471                  and then Is_Formal (Entity (L))
 472                then
 473                   Error_Msg_N
 474                     ("?assignment to pass-by-copy formal may have no effect",
 475                       P);
 476                   Error_Msg_N
 477                     ("\?RAISE statement may result in abnormal return" &
 478                      " (RM 6.4.1(17))", P);
 479                end if;
 480             end if;
 481          end;
 482       end if;
 483
 484       --  Reraise statement
 485
 486       if No (Exception_Id) then
 487          P := Parent (N);
 488          while not Nkind_In (P, N_Exception_Handler,
 489                                 N_Subprogram_Body,
 490                                 N_Package_Body,
 491                                 N_Task_Body,
 492                                 N_Entry_Body)
 493          loop
 494             P := Parent (P);
 495          end loop;
 496
 497          if Nkind (P) /= N_Exception_Handler then
 498             Error_Msg_N
 499               ("reraise statement must appear directly in a handler", N);
 500
 501          --  If a handler has a reraise, it cannot be the target of a local
 502          --  raise (goto optimization is impossible), and if the no exception
 503          --  propagation restriction is set, this is a violation.
 504
 505          else
 506             Set_Local_Raise_Not_OK (P);
 507
 508             --  Do not check the restriction if the reraise statement is part
 509             --  of the code generated for an AT-END handler. That's because
 510             --  if the restriction is actually active, we never generate this
 511             --  raise anyway, so the apparent violation is bogus.
 512
 513             if not From_At_End (N) then
 514                Check_Restriction (No_Exception_Propagation, N);
 515             end if;
 516          end if;
 517
 518       --  Normal case with exception id present
 519
 520       else
 521          Analyze (Exception_Id);
 522
 523          if Is_Entity_Name (Exception_Id) then
 524             Exception_Name := Entity (Exception_Id);
 525          end if;
 526
 527          if No (Exception_Name)
 528            or else Ekind (Exception_Name) /= E_Exception
 529          then
 530             Error_Msg_N
 531               ("exception name expected in raise statement", Exception_Id);
 532          else
 533             Set_Is_Raised (Exception_Name);
 534          end if;
 535
 536          --  Deal with RAISE WITH case
 537
 538          if Present (Expression (N)) then
 539             Check_Compiler_Unit (Expression (N));
 540             Analyze_And_Resolve (Expression (N), Standard_String);
 541          end if;
 542       end if;
 543
 544       --  Check obsolescent use of Numeric_Error
 545
 546       if Exception_Name = Standard_Numeric_Error then
 547          Check_Restriction (No_Obsolescent_Features, Exception_Id);
 548       end if;
 549
 550       --  Kill last assignment indication
 551
 552       Kill_Current_Values (Last_Assignment_Only => True);
 553    end Analyze_Raise_Statement;
 554
 555    -----------------------------
 556    -- Analyze_Raise_xxx_Error --
 557    -----------------------------
 558
 559    --  Normally, the Etype is already set (when this node is used within
 560    --  an expression, since it is copied from the node which it rewrites).
 561    --  If this node is used in a statement context, then we set the type
 562    --  Standard_Void_Type. This is used both by Gigi and by the front end
 563    --  to distinguish the statement use and the subexpression use.
 564
 565    --  The only other required processing is to take care of the Condition
 566    --  field if one is present.
 567
 568    procedure Analyze_Raise_xxx_Error (N : Node_Id) is
 569
 570       function Same_Expression (C1, C2 : Node_Id) return Boolean;
 571       --  It often occurs that two identical raise statements are generated in
 572       --  succession (for example when dynamic elaboration checks take place on
 573       --  separate expressions in a call). If the two statements are identical
 574       --  according to the simple criterion that follows, the raise is
 575       --  converted into a null statement.
 576
 577       ---------------------
 578       -- Same_Expression --
 579       ---------------------
 580
 581       function Same_Expression (C1, C2 : Node_Id) return Boolean is
 582       begin
 583          if No (C1) and then No (C2) then
 584             return True;
 585
 586          elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
 587             return Entity (C1) = Entity (C2);
 588
 589          elsif Nkind (C1) /= Nkind (C2) then
 590             return False;
 591
 592          elsif Nkind (C1) in N_Unary_Op then
 593             return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
 594
 595          elsif Nkind (C1) in N_Binary_Op then
 596             return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
 597               and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
 598
 599          elsif Nkind (C1) = N_Null then
 600             return True;
 601
 602          else
 603             return False;
 604          end if;
 605       end Same_Expression;
 606
 607    --  Start of processing for Analyze_Raise_xxx_Error
 608
 609    begin
 610       if No (Etype (N)) then
 611          Set_Etype (N, Standard_Void_Type);
 612       end if;
 613
 614       if Present (Condition (N)) then
 615          Analyze_And_Resolve (Condition (N), Standard_Boolean);
 616       end if;
 617
 618       --  Deal with static cases in obvious manner
 619
 620       if Nkind (Condition (N)) = N_Identifier then
 621          if Entity (Condition (N)) = Standard_True then
 622             Set_Condition (N, Empty);
 623
 624          elsif Entity (Condition (N)) = Standard_False then
 625             Rewrite (N, Make_Null_Statement (Sloc (N)));
 626          end if;
 627       end if;
 628
 629       --  Remove duplicate raise statements. Note that the previous one may
 630       --  already have been removed as well.
 631
 632       if not Comes_From_Source (N)
 633         and then Nkind (N) /= N_Null_Statement
 634         and then Is_List_Member (N)
 635         and then Present (Prev (N))
 636         and then Nkind (N) = Nkind (Original_Node (Prev (N)))
 637         and then Same_Expression
 638                    (Condition (N), Condition (Original_Node (Prev (N))))
 639       then
 640          Rewrite (N, Make_Null_Statement (Sloc (N)));
 641       end if;
 642    end Analyze_Raise_xxx_Error;
 643
 644    -----------------------------
 645    -- Analyze_Subprogram_Info --
 646    -----------------------------
 647
 648    procedure Analyze_Subprogram_Info (N : Node_Id) is
 649    begin
 650       Set_Etype (N, RTE (RE_Code_Loc));
 651    end Analyze_Subprogram_Info;
 652
 653 end Sem_Ch11;