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