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