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