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