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