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 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Lib; use Lib; 32with Lib.Xref; use Lib.Xref; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; use Opt; 36with Restrict; use Restrict; 37with Rtsfind; use Rtsfind; 38with Sem; use Sem; 39with Sem_Ch5; use Sem_Ch5; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Res; use Sem_Res; 42with Sem_Util; use Sem_Util; 43with Sinfo; use Sinfo; 44with Stand; use Stand; 45with Uintp; use Uintp; 46 47package 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 492end Sem_Ch11; 493