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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  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
  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       -----------------------
  83       -- Check_Duplication --
  84       -----------------------
  85
  86       procedure Check_Duplication (Id : Node_Id) is
  87          Handler : Node_Id;
  88          Id1     : Node_Id;
  89
  90       begin
  91          Handler := First_Non_Pragma (L);
  92          while Present (Handler) loop
  93             Id1 := First (Exception_Choices (Handler));
  94
  95             while Present (Id1) loop
  96
  97                --  Only check against the exception choices which precede
  98                --  Id in the handler, since the ones that follow Id have not
  99                --  been analyzed yet and will be checked in a subsequent call.
 100
 101                if Id = Id1 then
 102                   return;
 103
 104                elsif Nkind (Id1) /= N_Others_Choice
 105                  and then Entity (Id) = Entity (Id1)
 106                then
 107                   if Handler /= Parent (Id) then
 108                      Error_Msg_Sloc := Sloc (Id1);
 109                      Error_Msg_NE
 110                        ("exception choice duplicates &#", Id, Id1);
 111
 112                   else
 113                      if Ada_83 and then Comes_From_Source (Id) then
 114                         Error_Msg_N
 115                           ("(Ada 83): duplicate exception choice&", Id);
 116                      end if;
 117                   end if;
 118                end if;
 119
 120                Next_Non_Pragma (Id1);
 121             end loop;
 122
 123             Next (Handler);
 124          end loop;
 125       end Check_Duplication;
 126
 127    --  Start processing for Analyze_Exception_Handlers
 128
 129    begin
 130       Handler := First (L);
 131       Check_Restriction (No_Exceptions, Handler);
 132       Check_Restriction (No_Exception_Handlers, Handler);
 133
 134       --  Loop through handlers (which can include pragmas)
 135
 136       while Present (Handler) loop
 137
 138          --  If pragma just analyze it
 139
 140          if Nkind (Handler) = N_Pragma then
 141             Analyze (Handler);
 142
 143          --  Otherwise we have a real exception handler
 144
 145          else
 146             --  Deal with choice parameter. The exception handler is
 147             --  a declarative part for it, so it constitutes a scope
 148             --  for visibility purposes. We create an entity to denote
 149             --  the whole exception part, and use it as the scope of all
 150             --  the choices, which may even have the same name without
 151             --  conflict. This scope plays no other role in expansion or
 152             --  or code generation.
 153
 154             Choice := Choice_Parameter (Handler);
 155
 156             if Present (Choice) then
 157
 158                if No (H_Scope) then
 159                   H_Scope := New_Internal_Entity
 160                     (E_Block, Current_Scope, Sloc (Choice), 'E');
 161                end if;
 162
 163                New_Scope (H_Scope);
 164                Set_Etype (H_Scope, Standard_Void_Type);
 165
 166                --  Set the Finalization Chain entity to Error means that it
 167                --  should not be used at that level but the parent one
 168                --  should be used instead.
 169
 170                --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
 171                --  ??? using Error for this non-error condition is nasty ???
 172
 173                Set_Finalization_Chain_Entity (H_Scope, Error);
 174
 175                Enter_Name (Choice);
 176                Set_Ekind (Choice, E_Variable);
 177                Set_Etype (Choice, RTE (RE_Exception_Occurrence));
 178                Generate_Definition (Choice);
 179             end if;
 180
 181             Id := First (Exception_Choices (Handler));
 182             while Present (Id) loop
 183                if Nkind (Id) = N_Others_Choice then
 184                   if Present (Next (Id))
 185                     or else Present (Next (Handler))
 186                     or else Present (Prev (Id))
 187                   then
 188                      Error_Msg_N ("OTHERS must appear alone and last", Id);
 189                   end if;
 190
 191                else
 192                   Analyze (Id);
 193
 194                   if not Is_Entity_Name (Id)
 195                     or else Ekind (Entity (Id)) /= E_Exception
 196                   then
 197                      Error_Msg_N ("exception name expected", Id);
 198
 199                   else
 200                      if Present (Renamed_Entity (Entity (Id))) then
 201                         Set_Entity (Id, Renamed_Entity (Entity (Id)));
 202                      end if;
 203
 204                      Check_Duplication (Id);
 205
 206                      --  Check for exception declared within generic formal
 207                      --  package (which is illegal, see RM 11.2(8))
 208
 209                      declare
 210                         Ent  : Entity_Id := Entity (Id);
 211                         Scop : Entity_Id := Scope (Ent);
 212
 213                      begin
 214                         while Scop /= Standard_Standard
 215                           and then Ekind (Scop) = E_Package
 216                         loop
 217                            --  If the exception is declared in an inner
 218                            --  instance, nothing else to check.
 219
 220                            if Is_Generic_Instance (Scop) then
 221                               exit;
 222
 223                            elsif Nkind (Declaration_Node (Scop)) =
 224                                            N_Package_Specification
 225                              and then
 226                                Nkind (Original_Node (Parent
 227                                  (Declaration_Node (Scop)))) =
 228                                            N_Formal_Package_Declaration
 229                            then
 230                               Error_Msg_NE
 231                                 ("exception& is declared in "  &
 232                                  "generic formal package", Id, Ent);
 233                               Error_Msg_N
 234                                 ("\and therefore cannot appear in " &
 235                                  "handler ('R'M 11.2(8))", Id);
 236                               exit;
 237                            end if;
 238
 239                            Scop := Scope (Scop);
 240                         end loop;
 241                      end;
 242                   end if;
 243                end if;
 244
 245                Next (Id);
 246             end loop;
 247
 248             Analyze_Statements (Statements (Handler));
 249
 250             if Present (Choice) then
 251                End_Scope;
 252             end if;
 253
 254          end if;
 255
 256          Next (Handler);
 257       end loop;
 258    end Analyze_Exception_Handlers;
 259
 260    --------------------------------
 261    -- Analyze_Handled_Statements --
 262    --------------------------------
 263
 264    procedure Analyze_Handled_Statements (N : Node_Id) is
 265       Handlers : constant List_Id := Exception_Handlers (N);
 266
 267    begin
 268       Analyze_Statements (Statements (N));
 269
 270       if Present (Handlers) then
 271          Analyze_Exception_Handlers (Handlers);
 272
 273       elsif Present (At_End_Proc (N)) then
 274          Analyze (At_End_Proc (N));
 275       end if;
 276    end Analyze_Handled_Statements;
 277
 278    -----------------------------
 279    -- Analyze_Raise_Statement --
 280    -----------------------------
 281
 282    procedure Analyze_Raise_Statement (N : Node_Id) is
 283       Exception_Id   : constant Node_Id := Name (N);
 284       Exception_Name : Entity_Id := Empty;
 285       P              : Node_Id;
 286       Nkind_P        : Node_Kind;
 287
 288    begin
 289       Check_Unreachable_Code (N);
 290
 291       --  Check exception restrictions on the original source
 292
 293       if Comes_From_Source (N) then
 294          Check_Restriction (No_Exceptions, N);
 295       end if;
 296
 297       --  Reraise statement
 298
 299       if No (Exception_Id) then
 300
 301          P := Parent (N);
 302          Nkind_P := Nkind (P);
 303
 304          while Nkind_P /= N_Exception_Handler
 305            and then Nkind_P /= N_Subprogram_Body
 306            and then Nkind_P /= N_Package_Body
 307            and then Nkind_P /= N_Task_Body
 308            and then Nkind_P /= N_Entry_Body
 309          loop
 310             P := Parent (P);
 311             Nkind_P := Nkind (P);
 312          end loop;
 313
 314          if Nkind (P) /= N_Exception_Handler then
 315             Error_Msg_N
 316               ("reraise statement must appear directly in a handler", N);
 317          end if;
 318
 319       --  Normal case with exception id present
 320
 321       else
 322          Analyze (Exception_Id);
 323
 324          if Is_Entity_Name (Exception_Id) then
 325             Exception_Name := Entity (Exception_Id);
 326          end if;
 327
 328          if No (Exception_Name)
 329            or else Ekind (Exception_Name) /= E_Exception
 330          then
 331             Error_Msg_N
 332               ("exception name expected in raise statement", Exception_Id);
 333          end if;
 334       end if;
 335    end Analyze_Raise_Statement;
 336
 337    -----------------------------
 338    -- Analyze_Raise_xxx_Error --
 339    -----------------------------
 340
 341    --  Normally, the Etype is already set (when this node is used within
 342    --  an expression, since it is copied from the node which it rewrites).
 343    --  If this node is used in a statement context, then we set the type
 344    --  Standard_Void_Type. This is used both by Gigi and by the front end
 345    --  to distinguish the statement use and the subexpression use.
 346
 347    --  The only other required processing is to take care of the Condition
 348    --  field if one is present.
 349
 350    procedure Analyze_Raise_xxx_Error (N : Node_Id) is
 351    begin
 352       if No (Etype (N)) then
 353          Set_Etype (N, Standard_Void_Type);
 354       end if;
 355
 356       if Present (Condition (N)) then
 357          Analyze_And_Resolve (Condition (N), Standard_Boolean);
 358       end if;
 359
 360       --  Deal with static cases in obvious manner
 361
 362       if Nkind (Condition (N)) = N_Identifier then
 363          if Entity (Condition (N)) = Standard_True then
 364             Set_Condition (N, Empty);
 365
 366          elsif Entity (Condition (N)) = Standard_False then
 367             Rewrite (N, Make_Null_Statement (Sloc (N)));
 368          end if;
 369       end if;
 370
 371    end Analyze_Raise_xxx_Error;
 372
 373    -----------------------------
 374    -- Analyze_Subprogram_Info --
 375    -----------------------------
 376
 377    procedure Analyze_Subprogram_Info (N : Node_Id) is
 378    begin
 379       Set_Etype (N, RTE (RE_Code_Loc));
 380    end Analyze_Subprogram_Info;
 381
 382 end Sem_Ch11;