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-2002 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 Einfo;    use Einfo;
  29 with Errout;   use Errout;
  30 with Lib;      use Lib;
  31 with Lib.Xref; use Lib.Xref;
  32 with Nlists;   use Nlists;
  33 with Nmake;    use Nmake;
  34 with Opt;      use Opt;
  35 with Restrict; use Restrict;
  36 with Rtsfind;  use Rtsfind;
  37 with Sem;      use Sem;
  38 with Sem_Ch5;  use Sem_Ch5;
  39 with Sem_Ch8;  use Sem_Ch8;
  40 with Sem_Res;  use Sem_Res;
  41 with Sem_Util; use Sem_Util;
  42 with Sinfo;    use Sinfo;
  43 with Stand;    use Stand;
  44 with Uintp;    use Uintp;
  45
  46 package body Sem_Ch11 is
  47
  48    -----------------------------------
  49    -- Analyze_Exception_Declaration --
  50    -----------------------------------
  51
  52    procedure Analyze_Exception_Declaration (N : Node_Id) is
  53       Id : constant Entity_Id := Defining_Identifier (N);
  54       PF : constant Boolean   := Is_Pure (Current_Scope);
  55
  56    begin
  57       Generate_Definition (Id);
  58       Enter_Name          (Id);
  59       Set_Ekind           (Id, E_Exception);
  60       Set_Exception_Code  (Id, Uint_0);
  61       Set_Etype           (Id, Standard_Exception_Type);
  62
  63       Set_Is_Statically_Allocated (Id);
  64       Set_Is_Pure (Id, PF);
  65
  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       -----------------------
  82       -- Check_Duplication --
  83       -----------------------
  84
  85       procedure Check_Duplication (Id : Node_Id) is
  86          Handler : Node_Id;
  87          Id1     : Node_Id;
  88
  89       begin
  90          Handler := First_Non_Pragma (L);
  91          while Present (Handler) loop
  92             Id1 := First (Exception_Choices (Handler));
  93
  94             while Present (Id1) loop
  95
  96                --  Only check against the exception choices which precede
  97                --  Id in the handler, since the ones that follow Id have not
  98                --  been analyzed yet and will be checked in a subsequent call.
  99
 100                if Id = Id1 then
 101                   return;
 102
 103                elsif Nkind (Id1) /= N_Others_Choice
 104                  and then Entity (Id) = Entity (Id1)
 105                then
 106                   if Handler /= Parent (Id) then
 107                      Error_Msg_Sloc := Sloc (Id1);
 108                      Error_Msg_NE
 109                        ("exception choice duplicates &#", Id, Id1);
 110
 111                   else
 112                      if Ada_83 and then Comes_From_Source (Id) then
 113                         Error_Msg_N
 114                           ("(Ada 83): duplicate exception choice&", Id);
 115                      end if;
 116                   end if;
 117                end if;
 118
 119                Next_Non_Pragma (Id1);
 120             end loop;
 121
 122             Next (Handler);
 123          end loop;
 124       end Check_Duplication;
 125
 126    --  Start processing for Analyze_Exception_Handlers
 127
 128    begin
 129       Handler := First (L);
 130       Check_Restriction (No_Exceptions, Handler);
 131       Check_Restriction (No_Exception_Handlers, Handler);
 132
 133       --  Loop through handlers (which can include pragmas)
 134
 135       while Present (Handler) loop
 136
 137          --  If pragma just analyze it
 138
 139          if Nkind (Handler) = N_Pragma then
 140             Analyze (Handler);
 141
 142          --  Otherwise we have a real exception handler
 143
 144          else
 145             --  Deal with choice parameter. The exception handler is
 146             --  a declarative part for it, so it constitutes a scope
 147             --  for visibility purposes. We create an entity to denote
 148             --  the whole exception part, and use it as the scope of all
 149             --  the choices, which may even have the same name without
 150             --  conflict. This scope plays no other role in expansion or
 151             --  or code generation.
 152
 153             Choice := Choice_Parameter (Handler);
 154
 155             if Present (Choice) then
 156
 157                if No (H_Scope) then
 158                   H_Scope := New_Internal_Entity
 159                     (E_Block, Current_Scope, Sloc (Choice), 'E');
 160                end if;
 161
 162                New_Scope (H_Scope);
 163                Set_Etype (H_Scope, Standard_Void_Type);
 164
 165                --  Set the Finalization Chain entity to Error means that it
 166                --  should not be used at that level but the parent one
 167                --  should be used instead.
 168
 169                --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
 170                --  ??? using Error for this non-error condition is nasty ???
 171
 172                Set_Finalization_Chain_Entity (H_Scope, Error);
 173
 174                Enter_Name (Choice);
 175                Set_Ekind (Choice, E_Variable);
 176                Set_Etype (Choice, RTE (RE_Exception_Occurrence));
 177                Generate_Definition (Choice);
 178             end if;
 179
 180             Id := First (Exception_Choices (Handler));
 181             while Present (Id) loop
 182                if Nkind (Id) = N_Others_Choice then
 183                   if Present (Next (Id))
 184                     or else Present (Next (Handler))
 185                     or else Present (Prev (Id))
 186                   then
 187                      Error_Msg_N ("OTHERS must appear alone and last", Id);
 188                   end if;
 189
 190                else
 191                   Analyze (Id);
 192
 193                   if not Is_Entity_Name (Id)
 194                     or else Ekind (Entity (Id)) /= E_Exception
 195                   then
 196                      Error_Msg_N ("exception name expected", Id);
 197
 198                   else
 199                      if Present (Renamed_Entity (Entity (Id))) then
 200                         Set_Entity (Id, Renamed_Entity (Entity (Id)));
 201                      end if;
 202
 203                      Check_Duplication (Id);
 204
 205                      --  Check for exception declared within generic formal
 206                      --  package (which is illegal, see RM 11.2(8))
 207
 208                      declare
 209                         Ent  : Entity_Id := Entity (Id);
 210                         Scop : Entity_Id := Scope (Ent);
 211
 212                      begin
 213                         while Scop /= Standard_Standard
 214                           and then Ekind (Scop) = E_Package
 215                         loop
 216                            --  If the exception is declared in an inner
 217                            --  instance, nothing else to check.
 218
 219                            if Is_Generic_Instance (Scop) then
 220                               exit;
 221
 222                            elsif Nkind (Declaration_Node (Scop)) =
 223                                            N_Package_Specification
 224                              and then
 225                                Nkind (Original_Node (Parent
 226                                  (Declaration_Node (Scop)))) =
 227                                            N_Formal_Package_Declaration
 228                            then
 229                               Error_Msg_NE
 230                                 ("exception& is declared in "  &
 231                                  "generic formal package", Id, Ent);
 232                               Error_Msg_N
 233                                 ("\and therefore cannot appear in " &
 234                                  "handler ('R'M 11.2(8))", Id);
 235                               exit;
 236                            end if;
 237
 238                            Scop := Scope (Scop);
 239                         end loop;
 240                      end;
 241                   end if;
 242                end if;
 243
 244                Next (Id);
 245             end loop;
 246
 247             Analyze_Statements (Statements (Handler));
 248
 249             if Present (Choice) then
 250                End_Scope;
 251             end if;
 252
 253          end if;
 254
 255          Next (Handler);
 256       end loop;
 257    end Analyze_Exception_Handlers;
 258
 259    --------------------------------
 260    -- Analyze_Handled_Statements --
 261    --------------------------------
 262
 263    procedure Analyze_Handled_Statements (N : Node_Id) is
 264       Handlers : constant List_Id := Exception_Handlers (N);
 265
 266    begin
 267       Analyze_Statements (Statements (N));
 268
 269       if Present (Handlers) then
 270          Analyze_Exception_Handlers (Handlers);
 271
 272       elsif Present (At_End_Proc (N)) then
 273          Analyze (At_End_Proc (N));
 274       end if;
 275    end Analyze_Handled_Statements;
 276
 277    -----------------------------
 278    -- Analyze_Raise_Statement --
 279    -----------------------------
 280
 281    procedure Analyze_Raise_Statement (N : Node_Id) is
 282       Exception_Id   : constant Node_Id := Name (N);
 283       Exception_Name : Entity_Id := Empty;
 284       P              : Node_Id;
 285       Nkind_P        : Node_Kind;
 286
 287    begin
 288       Check_Unreachable_Code (N);
 289
 290       --  Check exception restrictions on the original source
 291
 292       if Comes_From_Source (N) then
 293          Check_Restriction (No_Exceptions, N);
 294       end if;
 295
 296       --  Reraise statement
 297
 298       if No (Exception_Id) then
 299
 300          P := Parent (N);
 301          Nkind_P := Nkind (P);
 302
 303          while Nkind_P /= N_Exception_Handler
 304            and then Nkind_P /= N_Subprogram_Body
 305            and then Nkind_P /= N_Package_Body
 306            and then Nkind_P /= N_Task_Body
 307            and then Nkind_P /= N_Entry_Body
 308          loop
 309             P := Parent (P);
 310             Nkind_P := Nkind (P);
 311          end loop;
 312
 313          if Nkind (P) /= N_Exception_Handler then
 314             Error_Msg_N
 315               ("reraise statement must appear directly in a handler", N);
 316          end if;
 317
 318       --  Normal case with exception id present
 319
 320       else
 321          Analyze (Exception_Id);
 322
 323          if Is_Entity_Name (Exception_Id) then
 324             Exception_Name := Entity (Exception_Id);
 325          end if;
 326
 327          if No (Exception_Name)
 328            or else Ekind (Exception_Name) /= E_Exception
 329          then
 330             Error_Msg_N
 331               ("exception name expected in raise statement", Exception_Id);
 332          end if;
 333       end if;
 334    end Analyze_Raise_Statement;
 335
 336    -----------------------------
 337    -- Analyze_Raise_xxx_Error --
 338    -----------------------------
 339
 340    --  Normally, the Etype is already set (when this node is used within
 341    --  an expression, since it is copied from the node which it rewrites).
 342    --  If this node is used in a statement context, then we set the type
 343    --  Standard_Void_Type. This is used both by Gigi and by the front end
 344    --  to distinguish the statement use and the subexpression use.
 345
 346    --  The only other required processing is to take care of the Condition
 347    --  field if one is present.
 348
 349    procedure Analyze_Raise_xxx_Error (N : Node_Id) is
 350    begin
 351       if No (Etype (N)) then
 352          Set_Etype (N, Standard_Void_Type);
 353       end if;
 354
 355       if Present (Condition (N)) then
 356          Analyze_And_Resolve (Condition (N), Standard_Boolean);
 357       end if;
 358
 359       --  Deal with static cases in obvious manner
 360
 361       if Nkind (Condition (N)) = N_Identifier then
 362          if Entity (Condition (N)) = Standard_True then
 363             Set_Condition (N, Empty);
 364
 365          elsif Entity (Condition (N)) = Standard_False then
 366             Rewrite (N, Make_Null_Statement (Sloc (N)));
 367          end if;
 368       end if;
 369
 370    end Analyze_Raise_xxx_Error;
 371
 372    -----------------------------
 373    -- Analyze_Subprogram_Info --
 374    -----------------------------
 375
 376    procedure Analyze_Subprogram_Info (N : Node_Id) is
 377    begin
 378       Set_Etype (N, RTE (RE_Code_Loc));
 379    end Analyze_Subprogram_Info;
 380
 381 end Sem_Ch11;