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