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