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