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