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