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