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-2012, 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 3, 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Lib; use Lib; 31with Lib.Xref; use Lib.Xref; 32with Namet; use Namet; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; use Opt; 36with Restrict; use Restrict; 37with Rident; use Rident; 38with Rtsfind; use Rtsfind; 39with Sem; use Sem; 40with Sem_Ch5; use Sem_Ch5; 41with Sem_Ch8; use Sem_Ch8; 42with Sem_Ch13; use Sem_Ch13; 43with Sem_Res; use Sem_Res; 44with Sem_Util; use Sem_Util; 45with Sem_Warn; use Sem_Warn; 46with Sinfo; use Sinfo; 47with Stand; use Stand; 48with Uintp; use Uintp; 49 50package body Sem_Ch11 is 51 52 ----------------------------------- 53 -- Analyze_Exception_Declaration -- 54 ----------------------------------- 55 56 procedure Analyze_Exception_Declaration (N : Node_Id) is 57 Id : constant Entity_Id := Defining_Identifier (N); 58 PF : constant Boolean := Is_Pure (Current_Scope); 59 begin 60 Generate_Definition (Id); 61 Enter_Name (Id); 62 Set_Ekind (Id, E_Exception); 63 Set_Exception_Code (Id, Uint_0); 64 Set_Etype (Id, Standard_Exception_Type); 65 Set_Is_Statically_Allocated (Id); 66 Set_Is_Pure (Id, PF); 67 68 if Has_Aspects (N) then 69 Analyze_Aspect_Specifications (N, Id); 70 end if; 71 end Analyze_Exception_Declaration; 72 73 -------------------------------- 74 -- Analyze_Exception_Handlers -- 75 -------------------------------- 76 77 procedure Analyze_Exception_Handlers (L : List_Id) is 78 Handler : Node_Id; 79 Choice : Entity_Id; 80 Id : Node_Id; 81 H_Scope : Entity_Id := Empty; 82 83 procedure Check_Duplication (Id : Node_Id); 84 -- Iterate through the identifiers in each handler to find duplicates 85 86 function Others_Present return Boolean; 87 -- Returns True if others handler is present 88 89 ----------------------- 90 -- Check_Duplication -- 91 ----------------------- 92 93 procedure Check_Duplication (Id : Node_Id) is 94 Handler : Node_Id; 95 Id1 : Node_Id; 96 Id_Entity : Entity_Id := Entity (Id); 97 98 begin 99 if Present (Renamed_Entity (Id_Entity)) then 100 Id_Entity := Renamed_Entity (Id_Entity); 101 end if; 102 103 Handler := First_Non_Pragma (L); 104 while Present (Handler) loop 105 Id1 := First (Exception_Choices (Handler)); 106 while Present (Id1) loop 107 108 -- Only check against the exception choices which precede 109 -- Id in the handler, since the ones that follow Id have not 110 -- been analyzed yet and will be checked in a subsequent call. 111 112 if Id = Id1 then 113 return; 114 115 elsif Nkind (Id1) /= N_Others_Choice 116 and then 117 (Id_Entity = Entity (Id1) 118 or else (Id_Entity = Renamed_Entity (Entity (Id1)))) 119 then 120 if Handler /= Parent (Id) then 121 Error_Msg_Sloc := Sloc (Id1); 122 Error_Msg_NE 123 ("exception choice duplicates &#", Id, Id1); 124 125 else 126 if Ada_Version = Ada_83 127 and then Comes_From_Source (Id) 128 then 129 Error_Msg_N 130 ("(Ada 83): duplicate exception choice&", Id); 131 end if; 132 end if; 133 end if; 134 135 Next_Non_Pragma (Id1); 136 end loop; 137 138 Next (Handler); 139 end loop; 140 end Check_Duplication; 141 142 -------------------- 143 -- Others_Present -- 144 -------------------- 145 146 function Others_Present return Boolean is 147 H : Node_Id; 148 149 begin 150 H := First (L); 151 while Present (H) loop 152 if Nkind (H) /= N_Pragma 153 and then Nkind (First (Exception_Choices (H))) = N_Others_Choice 154 then 155 return True; 156 end if; 157 158 Next (H); 159 end loop; 160 161 return False; 162 end Others_Present; 163 164 -- Start of processing for Analyze_Exception_Handlers 165 166 begin 167 Handler := First (L); 168 Check_Restriction (No_Exceptions, Handler); 169 Check_Restriction (No_Exception_Handlers, Handler); 170 171 -- Kill current remembered values, since we don't know where we were 172 -- when the exception was raised. 173 174 Kill_Current_Values; 175 176 -- Loop through handlers (which can include pragmas) 177 178 while Present (Handler) loop 179 180 -- If pragma just analyze it 181 182 if Nkind (Handler) = N_Pragma then 183 Analyze (Handler); 184 185 -- Otherwise we have a real exception handler 186 187 else 188 -- Deal with choice parameter. The exception handler is a 189 -- declarative part for the choice parameter, so it constitutes a 190 -- scope for visibility purposes. We create an entity to denote 191 -- the whole exception part, and use it as the scope of all the 192 -- choices, which may even have the same name without conflict. 193 -- This scope plays no other role in expansion or code generation. 194 195 Choice := Choice_Parameter (Handler); 196 197 if Present (Choice) then 198 Set_Local_Raise_Not_OK (Handler); 199 200 if Comes_From_Source (Choice) then 201 Check_Restriction (No_Exception_Propagation, Choice); 202 end if; 203 204 if No (H_Scope) then 205 H_Scope := 206 New_Internal_Entity 207 (E_Block, Current_Scope, Sloc (Choice), 'E'); 208 end if; 209 210 Push_Scope (H_Scope); 211 Set_Etype (H_Scope, Standard_Void_Type); 212 213 Enter_Name (Choice); 214 Set_Ekind (Choice, E_Variable); 215 216 if RTE_Available (RE_Exception_Occurrence) then 217 Set_Etype (Choice, RTE (RE_Exception_Occurrence)); 218 end if; 219 220 Generate_Definition (Choice); 221 222 -- Indicate that choice has an initial value, since in effect 223 -- this field is assigned an initial value by the exception. 224 -- We also consider that it is modified in the source. 225 226 Set_Has_Initial_Value (Choice, True); 227 Set_Never_Set_In_Source (Choice, False); 228 end if; 229 230 Id := First (Exception_Choices (Handler)); 231 while Present (Id) loop 232 if Nkind (Id) = N_Others_Choice then 233 if Present (Next (Id)) 234 or else Present (Next (Handler)) 235 or else Present (Prev (Id)) 236 then 237 Error_Msg_N ("OTHERS must appear alone and last", Id); 238 end if; 239 240 else 241 Analyze (Id); 242 243 -- In most cases the choice has already been analyzed in 244 -- Analyze_Handled_Statement_Sequence, in order to expand 245 -- local handlers. This advance analysis does not take into 246 -- account the case in which a choice has the same name as 247 -- the choice parameter of the handler, which may hide an 248 -- outer exception. This pathological case appears in ACATS 249 -- B80001_3.adb, and requires an explicit check to verify 250 -- that the id is not hidden. 251 252 if not Is_Entity_Name (Id) 253 or else Ekind (Entity (Id)) /= E_Exception 254 or else 255 (Nkind (Id) = N_Identifier 256 and then Chars (Id) = Chars (Choice)) 257 then 258 Error_Msg_N ("exception name expected", Id); 259 260 else 261 -- Emit a warning at the declaration level when a local 262 -- exception is never raised explicitly. 263 264 if Warn_On_Redundant_Constructs 265 and then not Is_Raised (Entity (Id)) 266 and then Scope (Entity (Id)) = Current_Scope 267 then 268 Error_Msg_NE 269 ("exception & is never raised?r?", Entity (Id), Id); 270 end if; 271 272 if Present (Renamed_Entity (Entity (Id))) then 273 if Entity (Id) = Standard_Numeric_Error then 274 Check_Restriction (No_Obsolescent_Features, Id); 275 276 if Warn_On_Obsolescent_Feature then 277 Error_Msg_N 278 ("Numeric_Error is an " & 279 "obsolescent feature (RM J.6(1))?j?", Id); 280 Error_Msg_N 281 ("\use Constraint_Error instead?j?", Id); 282 end if; 283 end if; 284 end if; 285 286 Check_Duplication (Id); 287 288 -- Check for exception declared within generic formal 289 -- package (which is illegal, see RM 11.2(8)) 290 291 declare 292 Ent : Entity_Id := Entity (Id); 293 Scop : Entity_Id; 294 295 begin 296 if Present (Renamed_Entity (Ent)) then 297 Ent := Renamed_Entity (Ent); 298 end if; 299 300 Scop := Scope (Ent); 301 while Scop /= Standard_Standard 302 and then Ekind (Scop) = E_Package 303 loop 304 if Nkind (Declaration_Node (Scop)) = 305 N_Package_Specification 306 and then 307 Nkind (Original_Node (Parent 308 (Declaration_Node (Scop)))) = 309 N_Formal_Package_Declaration 310 then 311 Error_Msg_NE 312 ("exception& is declared in " & 313 "generic formal package", Id, Ent); 314 Error_Msg_N 315 ("\and therefore cannot appear in " & 316 "handler (RM 11.2(8))", Id); 317 exit; 318 319 -- If the exception is declared in an inner 320 -- instance, nothing else to check. 321 322 elsif Is_Generic_Instance (Scop) then 323 exit; 324 end if; 325 326 Scop := Scope (Scop); 327 end loop; 328 end; 329 end if; 330 end if; 331 332 Next (Id); 333 end loop; 334 335 -- Check for redundant handler (has only raise statement) and is 336 -- either an others handler, or is a specific handler when no 337 -- others handler is present. 338 339 if Warn_On_Redundant_Constructs 340 and then List_Length (Statements (Handler)) = 1 341 and then Nkind (First (Statements (Handler))) = N_Raise_Statement 342 and then No (Name (First (Statements (Handler)))) 343 and then (not Others_Present 344 or else Nkind (First (Exception_Choices (Handler))) = 345 N_Others_Choice) 346 then 347 Error_Msg_N 348 ("useless handler contains only a reraise statement?r?", 349 Handler); 350 end if; 351 352 -- Now analyze the statements of this handler 353 354 Analyze_Statements (Statements (Handler)); 355 356 -- If a choice was present, we created a special scope for it, 357 -- so this is where we pop that special scope to get rid of it. 358 359 if Present (Choice) then 360 End_Scope; 361 end if; 362 end if; 363 364 Next (Handler); 365 end loop; 366 end Analyze_Exception_Handlers; 367 368 -------------------------------- 369 -- Analyze_Handled_Statements -- 370 -------------------------------- 371 372 procedure Analyze_Handled_Statements (N : Node_Id) is 373 Handlers : constant List_Id := Exception_Handlers (N); 374 Handler : Node_Id; 375 Choice : Node_Id; 376 377 begin 378 if Present (Handlers) then 379 Kill_All_Checks; 380 end if; 381 382 -- We are now going to analyze the statements and then the exception 383 -- handlers. We certainly need to do things in this order to get the 384 -- proper sequential semantics for various warnings. 385 386 -- However, there is a glitch. When we process raise statements, an 387 -- optimization is to look for local handlers and specialize the code 388 -- in this case. 389 390 -- In order to detect if a handler is matching, we must have at least 391 -- analyzed the choices in the proper scope so that proper visibility 392 -- analysis is performed. Hence we analyze just the choices first, 393 -- before we analyze the statement sequence. 394 395 Handler := First_Non_Pragma (Handlers); 396 while Present (Handler) loop 397 Choice := First_Non_Pragma (Exception_Choices (Handler)); 398 while Present (Choice) loop 399 Analyze (Choice); 400 Next_Non_Pragma (Choice); 401 end loop; 402 403 Next_Non_Pragma (Handler); 404 end loop; 405 406 -- Analyze statements in sequence 407 408 Analyze_Statements (Statements (N)); 409 410 -- If the current scope is a subprogram, then this is the right place to 411 -- check for hanging useless assignments from the statement sequence of 412 -- the subprogram body. 413 414 if Is_Subprogram (Current_Scope) then 415 Warn_On_Useless_Assignments (Current_Scope); 416 end if; 417 418 -- Deal with handlers or AT END proc 419 420 if Present (Handlers) then 421 Analyze_Exception_Handlers (Handlers); 422 elsif Present (At_End_Proc (N)) then 423 Analyze (At_End_Proc (N)); 424 end if; 425 end Analyze_Handled_Statements; 426 427 ----------------------------- 428 -- Analyze_Raise_Statement -- 429 ----------------------------- 430 431 procedure Analyze_Raise_Statement (N : Node_Id) is 432 Exception_Id : constant Node_Id := Name (N); 433 Exception_Name : Entity_Id := Empty; 434 P : Node_Id; 435 Par : Node_Id; 436 437 begin 438 Check_SPARK_Restriction ("raise statement is not allowed", N); 439 Check_Unreachable_Code (N); 440 441 -- Check exception restrictions on the original source 442 443 if Comes_From_Source (N) then 444 Check_Restriction (No_Exceptions, N); 445 end if; 446 447 -- Check for useless assignment to OUT or IN OUT scalar preceding the 448 -- raise. Right now only look at assignment statements, could do more??? 449 450 if Is_List_Member (N) then 451 declare 452 P : Node_Id; 453 L : Node_Id; 454 455 begin 456 P := Prev (N); 457 458 -- Skip past null statements and pragmas 459 460 while Present (P) 461 and then Nkind_In (P, N_Null_Statement, N_Pragma) 462 loop 463 P := Prev (P); 464 end loop; 465 466 -- See if preceding statement is an assignment 467 468 if Present (P) 469 and then Nkind (P) = N_Assignment_Statement 470 then 471 L := Name (P); 472 473 -- Give warning for assignment to scalar formal 474 475 if Is_Scalar_Type (Etype (L)) 476 and then Is_Entity_Name (L) 477 and then Is_Formal (Entity (L)) 478 then 479 -- Don't give warning if we are covered by an exception 480 -- handler, since this may result in false positives, since 481 -- the handler may handle the exception and return normally. 482 483 -- First find the enclosing handled sequence of statements 484 -- (note, we could also look for a handler in an outer block 485 -- but currently we don't, and in that case we'll emit the 486 -- warning). 487 488 Par := N; 489 loop 490 Par := Parent (Par); 491 exit when Nkind (Par) = N_Handled_Sequence_Of_Statements; 492 end loop; 493 494 -- See if there is a handler, give message if not 495 496 if No (Exception_Handlers (Par)) then 497 Error_Msg_N 498 ("assignment to pass-by-copy formal " & 499 "may have no effect??", P); 500 Error_Msg_N 501 ("\RAISE statement may result in abnormal return" & 502 " (RM 6.4.1(17))??", P); 503 end if; 504 end if; 505 end if; 506 end; 507 end if; 508 509 -- Reraise statement 510 511 if No (Exception_Id) then 512 P := Parent (N); 513 while not Nkind_In (P, N_Exception_Handler, 514 N_Subprogram_Body, 515 N_Package_Body, 516 N_Task_Body, 517 N_Entry_Body) 518 loop 519 P := Parent (P); 520 end loop; 521 522 if Nkind (P) /= N_Exception_Handler then 523 Error_Msg_N 524 ("reraise statement must appear directly in a handler", N); 525 526 -- If a handler has a reraise, it cannot be the target of a local 527 -- raise (goto optimization is impossible), and if the no exception 528 -- propagation restriction is set, this is a violation. 529 530 else 531 Set_Local_Raise_Not_OK (P); 532 533 -- Do not check the restriction if the reraise statement is part 534 -- of the code generated for an AT-END handler. That's because 535 -- if the restriction is actually active, we never generate this 536 -- raise anyway, so the apparent violation is bogus. 537 538 if not From_At_End (N) then 539 Check_Restriction (No_Exception_Propagation, N); 540 end if; 541 end if; 542 543 -- Normal case with exception id present 544 545 else 546 Analyze (Exception_Id); 547 548 if Is_Entity_Name (Exception_Id) then 549 Exception_Name := Entity (Exception_Id); 550 end if; 551 552 if No (Exception_Name) 553 or else Ekind (Exception_Name) /= E_Exception 554 then 555 Error_Msg_N 556 ("exception name expected in raise statement", Exception_Id); 557 else 558 Set_Is_Raised (Exception_Name); 559 end if; 560 561 -- Deal with RAISE WITH case 562 563 if Present (Expression (N)) then 564 Check_Compiler_Unit (Expression (N)); 565 Analyze_And_Resolve (Expression (N), Standard_String); 566 end if; 567 end if; 568 569 -- Check obsolescent use of Numeric_Error 570 571 if Exception_Name = Standard_Numeric_Error then 572 Check_Restriction (No_Obsolescent_Features, Exception_Id); 573 end if; 574 575 -- Kill last assignment indication 576 577 Kill_Current_Values (Last_Assignment_Only => True); 578 end Analyze_Raise_Statement; 579 580 ----------------------------- 581 -- Analyze_Raise_xxx_Error -- 582 ----------------------------- 583 584 -- Normally, the Etype is already set (when this node is used within 585 -- an expression, since it is copied from the node which it rewrites). 586 -- If this node is used in a statement context, then we set the type 587 -- Standard_Void_Type. This is used both by Gigi and by the front end 588 -- to distinguish the statement use and the subexpression use. 589 590 -- The only other required processing is to take care of the Condition 591 -- field if one is present. 592 593 procedure Analyze_Raise_xxx_Error (N : Node_Id) is 594 595 function Same_Expression (C1, C2 : Node_Id) return Boolean; 596 -- It often occurs that two identical raise statements are generated in 597 -- succession (for example when dynamic elaboration checks take place on 598 -- separate expressions in a call). If the two statements are identical 599 -- according to the simple criterion that follows, the raise is 600 -- converted into a null statement. 601 602 --------------------- 603 -- Same_Expression -- 604 --------------------- 605 606 function Same_Expression (C1, C2 : Node_Id) return Boolean is 607 begin 608 if No (C1) and then No (C2) then 609 return True; 610 611 elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then 612 return Entity (C1) = Entity (C2); 613 614 elsif Nkind (C1) /= Nkind (C2) then 615 return False; 616 617 elsif Nkind (C1) in N_Unary_Op then 618 return Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); 619 620 elsif Nkind (C1) in N_Binary_Op then 621 return Same_Expression (Left_Opnd (C1), Left_Opnd (C2)) 622 and then 623 Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); 624 625 elsif Nkind (C1) = N_Null then 626 return True; 627 628 else 629 return False; 630 end if; 631 end Same_Expression; 632 633 -- Start of processing for Analyze_Raise_xxx_Error 634 635 begin 636 Check_SPARK_Restriction ("raise statement is not allowed", N); 637 638 if No (Etype (N)) then 639 Set_Etype (N, Standard_Void_Type); 640 end if; 641 642 if Present (Condition (N)) then 643 Analyze_And_Resolve (Condition (N), Standard_Boolean); 644 end if; 645 646 -- Deal with static cases in obvious manner 647 648 if Nkind (Condition (N)) = N_Identifier then 649 if Entity (Condition (N)) = Standard_True then 650 Set_Condition (N, Empty); 651 652 elsif Entity (Condition (N)) = Standard_False then 653 Rewrite (N, Make_Null_Statement (Sloc (N))); 654 end if; 655 end if; 656 657 -- Remove duplicate raise statements. Note that the previous one may 658 -- already have been removed as well. 659 660 if not Comes_From_Source (N) 661 and then Nkind (N) /= N_Null_Statement 662 and then Is_List_Member (N) 663 and then Present (Prev (N)) 664 and then Nkind (N) = Nkind (Original_Node (Prev (N))) 665 and then Same_Expression 666 (Condition (N), Condition (Original_Node (Prev (N)))) 667 then 668 Rewrite (N, Make_Null_Statement (Sloc (N))); 669 end if; 670 end Analyze_Raise_xxx_Error; 671 672 ----------------------------- 673 -- Analyze_Subprogram_Info -- 674 ----------------------------- 675 676 procedure Analyze_Subprogram_Info (N : Node_Id) is 677 begin 678 Set_Etype (N, RTE (RE_Code_Loc)); 679 end Analyze_Subprogram_Info; 680 681end Sem_Ch11; 682