1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ 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 Debug; use Debug; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Errout; use Errout; 31with Exp_Ch7; use Exp_Ch7; 32with Exp_Intr; use Exp_Intr; 33with Exp_Util; use Exp_Util; 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_Ch8; use Sem_Ch8; 43with Sem_Res; use Sem_Res; 44with Sem_Util; use Sem_Util; 45with Sinfo; use Sinfo; 46with Sinput; use Sinput; 47with Snames; use Snames; 48with Stand; use Stand; 49with Stringt; use Stringt; 50with Targparm; use Targparm; 51with Tbuild; use Tbuild; 52with Uintp; use Uintp; 53 54package body Exp_Ch11 is 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 procedure Warn_No_Exception_Propagation_Active (N : Node_Id); 61 -- Generates warning that pragma Restrictions (No_Exception_Propagation) 62 -- is in effect. Caller then generates appropriate continuation message. 63 -- N is the node on which the warning is placed. 64 65 procedure Warn_If_No_Propagation (N : Node_Id); 66 -- Called for an exception raise that is not a local raise (and thus 67 -- cannot be optimized to a goto). Issues warning if 68 -- No_Exception_Propagation restriction is set. 69 -- N is the node for the raise or equivalent call. 70 71 --------------------------- 72 -- Expand_At_End_Handler -- 73 --------------------------- 74 75 -- For a handled statement sequence that has a cleanup (At_End_Proc 76 -- field set), an exception handler of the following form is required: 77 78 -- exception 79 -- when all others => 80 -- cleanup call 81 -- raise; 82 83 -- Note: this exception handler is treated rather specially by 84 -- subsequent expansion in two respects: 85 86 -- The normal call to Undefer_Abort is omitted 87 -- The raise call does not do Defer_Abort 88 89 -- This is because the current tasking code seems to assume that 90 -- the call to the cleanup routine that is made from an exception 91 -- handler for the abort signal is called with aborts deferred. 92 93 -- This expansion is only done if we have front end exception handling. 94 -- If we have back end exception handling, then the AT END handler is 95 -- left alone, and cleanups (including the exceptional case) are handled 96 -- by the back end. 97 98 -- In the front end case, the exception handler described above handles 99 -- the exceptional case. The AT END handler is left in the generated tree 100 -- and the code generator (e.g. gigi) must still handle proper generation 101 -- of cleanup calls for the non-exceptional case. 102 103 procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is 104 Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); 105 Ohandle : Node_Id; 106 Stmnts : List_Id; 107 108 Loc : constant Source_Ptr := No_Location; 109 -- Location used for expansion. We quite deliberately do not set a 110 -- specific source location for the expanded handler. This makes 111 -- sense since really the handler is not associated with specific 112 -- source. We used to set this to Sloc (Clean), but that caused 113 -- useless and annoying bouncing around of line numbers in the 114 -- debugger in some circumstances. 115 116 begin 117 pragma Assert (Present (Clean)); 118 pragma Assert (No (Exception_Handlers (HSS))); 119 120 -- Back end exception schemes don't need explicit handlers to 121 -- trigger AT-END actions on exceptional paths. 122 123 if Back_End_Exceptions then 124 return; 125 end if; 126 127 -- Don't expand an At End handler if we have already had configurable 128 -- run-time violations, since likely this will just be a matter of 129 -- generating useless cascaded messages 130 131 if Configurable_Run_Time_Violations > 0 then 132 return; 133 end if; 134 135 -- Don't expand an At End handler if we are not allowing exceptions 136 -- or if exceptions are transformed into local gotos, and never 137 -- propagated (No_Exception_Propagation). 138 139 if No_Exception_Handlers_Set then 140 return; 141 end if; 142 143 if Present (Blk_Id) then 144 Push_Scope (Blk_Id); 145 end if; 146 147 Ohandle := 148 Make_Others_Choice (Loc); 149 Set_All_Others (Ohandle); 150 151 Stmnts := New_List ( 152 Make_Procedure_Call_Statement (Loc, 153 Name => New_Occurrence_Of (Clean, Loc))); 154 155 -- Generate reraise statement as last statement of AT-END handler, 156 -- unless we are under control of No_Exception_Propagation, in which 157 -- case no exception propagation is possible anyway, so we do not need 158 -- a reraise (the AT END handler in this case is only for normal exits 159 -- not for exceptional exits). Also, we flag the Reraise statement as 160 -- being part of an AT END handler to prevent signalling this reraise 161 -- as a violation of the restriction when it is not set. 162 163 if not Restriction_Active (No_Exception_Propagation) then 164 declare 165 Rstm : constant Node_Id := Make_Raise_Statement (Loc); 166 begin 167 Set_From_At_End (Rstm); 168 Append_To (Stmnts, Rstm); 169 end; 170 end if; 171 172 Set_Exception_Handlers (HSS, New_List ( 173 Make_Implicit_Exception_Handler (Loc, 174 Exception_Choices => New_List (Ohandle), 175 Statements => Stmnts))); 176 177 Analyze_List (Stmnts, Suppress => All_Checks); 178 Expand_Exception_Handlers (HSS); 179 180 if Present (Blk_Id) then 181 Pop_Scope; 182 end if; 183 end Expand_At_End_Handler; 184 185 ------------------------------- 186 -- Expand_Exception_Handlers -- 187 ------------------------------- 188 189 procedure Expand_Exception_Handlers (HSS : Node_Id) is 190 Handlrs : constant List_Id := Exception_Handlers (HSS); 191 Loc : constant Source_Ptr := Sloc (HSS); 192 Handler : Node_Id; 193 Others_Choice : Boolean; 194 Obj_Decl : Node_Id; 195 Next_Handler : Node_Id; 196 197 procedure Expand_Local_Exception_Handlers; 198 -- This procedure handles the expansion of exception handlers for the 199 -- optimization of local raise statements into goto statements. 200 201 procedure Prepend_Call_To_Handler 202 (Proc : RE_Id; 203 Args : List_Id := No_List); 204 -- Routine to prepend a call to the procedure referenced by Proc at 205 -- the start of the handler code for the current Handler. 206 207 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id); 208 -- Raise_S is a raise statement (possibly expanded, and possibly of the 209 -- form of a Raise_xxx_Error node with a condition. This procedure is 210 -- called to replace the raise action with the (already analyzed) goto 211 -- statement passed as Goto_L1. This procedure also takes care of the 212 -- requirement of inserting a Local_Raise call where possible. 213 214 ------------------------------------- 215 -- Expand_Local_Exception_Handlers -- 216 ------------------------------------- 217 218 -- There are two cases for this transformation. First the case of 219 -- explicit raise statements. For this case, the transformation we do 220 -- looks like this. Right now we have for example (where L1, L2 are 221 -- exception labels) 222 223 -- begin 224 -- ... 225 -- raise_exception (excep1'identity); -- was raise excep1 226 -- ... 227 -- raise_exception (excep2'identity); -- was raise excep2 228 -- ... 229 -- exception 230 -- when excep1 => 231 -- estmts1 232 -- when excep2 => 233 -- estmts2 234 -- end; 235 236 -- This gets transformed into: 237 238 -- begin 239 -- L1 : label; -- marked Exception_Junk 240 -- L2 : label; -- marked Exception_Junk 241 -- L3 : label; -- marked Exception_Junk 242 243 -- begin -- marked Exception_Junk 244 -- ... 245 -- local_raise (excep1'address); -- was raise excep1 246 -- goto L1; 247 -- ... 248 -- local_raise (excep2'address); -- was raise excep2 249 -- goto L2; 250 -- ... 251 -- exception 252 -- when excep1 => 253 -- goto L1; 254 -- when excep2 => 255 -- goto L2; 256 -- end; 257 258 -- goto L3; -- skip handler if no raise, marked Exception_Junk 259 260 -- <<L1>> -- local excep target label, marked Exception_Junk 261 -- begin -- marked Exception_Junk 262 -- estmts1 263 -- end; 264 -- goto L3; -- marked Exception_Junk 265 266 -- <<L2>> -- marked Exception_Junk 267 -- begin -- marked Exception_Junk 268 -- estmts2 269 -- end; 270 -- goto L3; -- marked Exception_Junk 271 -- <<L3>> -- marked Exception_Junk 272 -- end; 273 274 -- Note: the reason we wrap the original statement sequence in an 275 -- inner block is that there may be raise statements within the 276 -- sequence of statements in the handlers, and we must ensure that 277 -- these are properly handled, and in particular, such raise statements 278 -- must not reenter the same exception handlers. 279 280 -- If the restriction No_Exception_Propagation is in effect, then we 281 -- can omit the exception handlers. 282 283 -- begin 284 -- L1 : label; -- marked Exception_Junk 285 -- L2 : label; -- marked Exception_Junk 286 -- L3 : label; -- marked Exception_Junk 287 288 -- begin -- marked Exception_Junk 289 -- ... 290 -- local_raise (excep1'address); -- was raise excep1 291 -- goto L1; 292 -- ... 293 -- local_raise (excep2'address); -- was raise excep2 294 -- goto L2; 295 -- ... 296 -- end; 297 298 -- goto L3; -- skip handler if no raise, marked Exception_Junk 299 300 -- <<L1>> -- local excep target label, marked Exception_Junk 301 -- begin -- marked Exception_Junk 302 -- estmts1 303 -- end; 304 -- goto L3; -- marked Exception_Junk 305 306 -- <<L2>> -- marked Exception_Junk 307 -- begin -- marked Exception_Junk 308 -- estmts2 309 -- end; 310 311 -- <<L3>> -- marked Exception_Junk 312 -- end; 313 314 -- The second case is for exceptions generated by the back end in one 315 -- of three situations: 316 317 -- 1. Front end generates N_Raise_xxx_Error node 318 -- 2. Front end sets Do_xxx_Check flag in subexpression node 319 -- 3. Back end detects a situation where an exception is appropriate 320 321 -- In all these cases, the current processing in gigi is to generate a 322 -- call to the appropriate Rcheck_xx routine (where xx encodes both the 323 -- exception message and the exception to be raised, Constraint_Error, 324 -- Program_Error, or Storage_Error. 325 326 -- We could handle some subcases of 1 using the same front end expansion 327 -- into gotos, but even for case 1, we can't handle all cases, since 328 -- generating gotos in the middle of expressions is not possible (it's 329 -- possible at the gigi/gcc level, but not at the level of the GNAT 330 -- tree). 331 332 -- In any case, it seems easier to have a scheme which handles all three 333 -- cases in a uniform manner. So here is how we proceed in this case. 334 335 -- This procedure detects all handlers for these three exceptions, 336 -- Constraint_Error, Program_Error and Storage_Error (including WHEN 337 -- OTHERS handlers that cover one or more of these cases). 338 339 -- If the handler meets the requirements for being the target of a local 340 -- raise, then the front end does the expansion described previously, 341 -- creating a label to be used as a goto target to raise the exception. 342 -- However, no attempt is made in the front end to convert any related 343 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are 344 -- left unchanged and passed to the back end. 345 346 -- Instead, the front end generates three nodes 347 348 -- N_Push_Constraint_Error_Label 349 -- N_Push_Program_Error_Label 350 -- N_Push_Storage_Error_Label 351 352 -- The Push node is generated at the start of the statements 353 -- covered by the handler, and has as a parameter the label to be 354 -- used as the raise target. 355 356 -- N_Pop_Constraint_Error_Label 357 -- N_Pop_Program_Error_Label 358 -- N_Pop_Storage_Error_Label 359 360 -- The Pop node is generated at the end of the covered statements 361 -- and undoes the effect of the preceding corresponding Push node. 362 363 -- In the case where the handler does NOT meet the requirements, the 364 -- front end will still generate the Push and Pop nodes, but the label 365 -- field in the Push node will be empty signifying that for this region 366 -- of code, no optimization is possible. 367 368 -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set 369 -- since they are useless in this case, and in CodePeer mode, where 370 -- they serve no purpose and can intefere with the analysis. 371 372 -- The back end must maintain three stacks, one for each exception case, 373 -- the Push node pushes an entry onto the corresponding stack, and Pop 374 -- node pops off the entry. Then instead of calling Rcheck_nn, if the 375 -- corresponding top stack entry has an non-empty label, a goto is 376 -- generated. This goto should be preceded by a call to Local_Raise as 377 -- described above. 378 379 -- An example of this transformation is as follows, given: 380 381 -- declare 382 -- A : Integer range 1 .. 10; 383 -- begin 384 -- A := B + C; 385 -- exception 386 -- when Constraint_Error => 387 -- estmts 388 -- end; 389 390 -- gets transformed to: 391 392 -- declare 393 -- A : Integer range 1 .. 10; 394 395 -- begin 396 -- L1 : label; 397 -- L2 : label; 398 399 -- begin 400 -- %push_constraint_error_label (L1) 401 -- R1b : constant long_long_integer := long_long_integer?(b) + 402 -- long_long_integer?(c); 403 -- [constraint_error when 404 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#) 405 -- "overflow check failed"] 406 -- a := integer?(R1b); 407 -- %pop_constraint_error_Label 408 409 -- exception 410 -- ... 411 -- when constraint_error => 412 -- goto L1; 413 -- end; 414 415 -- goto L2; -- skip handler when exception not raised 416 -- <<L1>> -- target label for local exception 417 -- estmts 418 -- <<L2>> 419 -- end; 420 421 -- Note: the generated labels and goto statements all have the flag 422 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore 423 -- this generated exception stuff when checking for missing return 424 -- statements (see circuitry in Check_Statement_Sequence). 425 426 -- Note: All of the processing described above occurs only if 427 -- restriction No_Exception_Propagation applies or debug flag .g is 428 -- enabled. 429 430 CE_Locally_Handled : Boolean := False; 431 SE_Locally_Handled : Boolean := False; 432 PE_Locally_Handled : Boolean := False; 433 -- These three flags indicate whether a handler for the corresponding 434 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error) 435 -- is present. If so the switch is set to True, the Exception_Label 436 -- field of the corresponding handler is set, and appropriate Push 437 -- and Pop nodes are inserted into the code. 438 439 Local_Expansion_Required : Boolean := False; 440 -- Set True if we have at least one handler requiring local raise 441 -- expansion as described above. 442 443 procedure Expand_Local_Exception_Handlers is 444 procedure Add_Exception_Label (H : Node_Id); 445 -- H is an exception handler. First check for an Exception_Label 446 -- already allocated for H. If none, allocate one, set the field in 447 -- the handler node, add the label declaration, and set the flag 448 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set 449 -- the call has no effect and Exception_Label is left empty. 450 451 procedure Add_Label_Declaration (L : Entity_Id); 452 -- Add an implicit declaration of the given label to the declaration 453 -- list in the parent of the current sequence of handled statements. 454 455 generic 456 Exc_Locally_Handled : in out Boolean; 457 -- Flag indicating whether a local handler for this exception 458 -- has already been generated. 459 460 with function Make_Push_Label (Loc : Source_Ptr) return Node_Id; 461 -- Function to create a Push_xxx_Label node 462 463 with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id; 464 -- Function to create a Pop_xxx_Label node 465 466 procedure Generate_Push_Pop (H : Node_Id); 467 -- Common code for Generate_Push_Pop_xxx below, used to generate an 468 -- exception label and Push/Pop nodes for Constraint_Error, 469 -- Program_Error, or Storage_Error. 470 471 ------------------------- 472 -- Add_Exception_Label -- 473 ------------------------- 474 475 procedure Add_Exception_Label (H : Node_Id) is 476 begin 477 if No (Exception_Label (H)) 478 and then not Local_Raise_Not_OK (H) 479 and then not Special_Exception_Package_Used 480 then 481 Local_Expansion_Required := True; 482 483 declare 484 L : constant Entity_Id := Make_Temporary (Sloc (H), 'L'); 485 begin 486 Set_Exception_Label (H, L); 487 Add_Label_Declaration (L); 488 end; 489 end if; 490 end Add_Exception_Label; 491 492 --------------------------- 493 -- Add_Label_Declaration -- 494 --------------------------- 495 496 procedure Add_Label_Declaration (L : Entity_Id) is 497 P : constant Node_Id := Parent (HSS); 498 499 Decl_L : constant Node_Id := 500 Make_Implicit_Label_Declaration (Loc, 501 Defining_Identifier => L); 502 503 begin 504 if Declarations (P) = No_List then 505 Set_Declarations (P, Empty_List); 506 end if; 507 508 Append (Decl_L, Declarations (P)); 509 Analyze (Decl_L); 510 end Add_Label_Declaration; 511 512 ----------------------- 513 -- Generate_Push_Pop -- 514 ----------------------- 515 516 procedure Generate_Push_Pop (H : Node_Id) is 517 begin 518 if Restriction_Active (No_Exception_Handlers) 519 or else CodePeer_Mode 520 then 521 return; 522 end if; 523 524 if Exc_Locally_Handled then 525 return; 526 else 527 Exc_Locally_Handled := True; 528 end if; 529 530 Add_Exception_Label (H); 531 532 declare 533 F : constant Node_Id := First (Statements (HSS)); 534 L : constant Node_Id := Last (Statements (HSS)); 535 536 Push : constant Node_Id := Make_Push_Label (Sloc (F)); 537 Pop : constant Node_Id := Make_Pop_Label (Sloc (L)); 538 539 begin 540 -- We make sure that a call to Get_Local_Raise_Call_Entity is 541 -- made during front end processing, so that when we need it 542 -- in the back end, it will already be available and loaded. 543 544 Discard_Node (Get_Local_Raise_Call_Entity); 545 546 -- Prepare and insert Push and Pop nodes 547 548 Set_Exception_Label (Push, Exception_Label (H)); 549 Insert_Before (F, Push); 550 Set_Analyzed (Push); 551 552 Insert_After (L, Pop); 553 Set_Analyzed (Pop); 554 end; 555 end Generate_Push_Pop; 556 557 -- Local declarations 558 559 Loc : constant Source_Ptr := Sloc (HSS); 560 Stmts : List_Id := No_List; 561 Choice : Node_Id; 562 Excep : Entity_Id; 563 564 procedure Generate_Push_Pop_For_Constraint_Error is 565 new Generate_Push_Pop 566 (Exc_Locally_Handled => CE_Locally_Handled, 567 Make_Push_Label => Make_Push_Constraint_Error_Label, 568 Make_Pop_Label => Make_Pop_Constraint_Error_Label); 569 -- If no Push/Pop has been generated for CE yet, then set the flag 570 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if 571 -- not already done), and generate Push/Pop nodes for the exception 572 -- label at the start and end of the statements of HSS. 573 574 procedure Generate_Push_Pop_For_Program_Error is 575 new Generate_Push_Pop 576 (Exc_Locally_Handled => PE_Locally_Handled, 577 Make_Push_Label => Make_Push_Program_Error_Label, 578 Make_Pop_Label => Make_Pop_Program_Error_Label); 579 -- If no Push/Pop has been generated for PE yet, then set the flag 580 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if 581 -- not already done), and generate Push/Pop nodes for the exception 582 -- label at the start and end of the statements of HSS. 583 584 procedure Generate_Push_Pop_For_Storage_Error is 585 new Generate_Push_Pop 586 (Exc_Locally_Handled => SE_Locally_Handled, 587 Make_Push_Label => Make_Push_Storage_Error_Label, 588 Make_Pop_Label => Make_Pop_Storage_Error_Label); 589 -- If no Push/Pop has been generated for SE yet, then set the flag 590 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if 591 -- not already done), and generate Push/Pop nodes for the exception 592 -- label at the start and end of the statements of HSS. 593 594 -- Start of processing for Expand_Local_Exception_Handlers 595 596 begin 597 -- No processing if all exception handlers will get removed 598 599 if Debug_Flag_Dot_X then 600 return; 601 end if; 602 603 -- See for each handler if we have any local raises to expand 604 605 Handler := First_Non_Pragma (Handlrs); 606 while Present (Handler) loop 607 608 -- Note, we do not test Local_Raise_Not_OK here, because in the 609 -- case of Push/Pop generation we want to generate push with a 610 -- null label. The Add_Exception_Label routine has no effect if 611 -- Local_Raise_Not_OK is set, so this works as required. 612 613 if Present (Local_Raise_Statements (Handler)) then 614 Add_Exception_Label (Handler); 615 end if; 616 617 -- If we are doing local raise to goto optimization (restriction 618 -- No_Exception_Propagation set or debug flag .g set), then check 619 -- to see if handler handles CE, PE, SE and if so generate the 620 -- appropriate push/pop sequence for the back end. 621 622 if (Debug_Flag_Dot_G 623 or else Restriction_Active (No_Exception_Propagation)) 624 and then Has_Local_Raise (Handler) 625 then 626 Choice := First (Exception_Choices (Handler)); 627 while Present (Choice) loop 628 if Nkind (Choice) = N_Others_Choice 629 and then not All_Others (Choice) 630 then 631 Generate_Push_Pop_For_Constraint_Error (Handler); 632 Generate_Push_Pop_For_Program_Error (Handler); 633 Generate_Push_Pop_For_Storage_Error (Handler); 634 635 elsif Is_Entity_Name (Choice) then 636 Excep := Get_Renamed_Entity (Entity (Choice)); 637 638 if Excep = Standard_Constraint_Error then 639 Generate_Push_Pop_For_Constraint_Error (Handler); 640 elsif Excep = Standard_Program_Error then 641 Generate_Push_Pop_For_Program_Error (Handler); 642 elsif Excep = Standard_Storage_Error then 643 Generate_Push_Pop_For_Storage_Error (Handler); 644 end if; 645 end if; 646 647 Next (Choice); 648 end loop; 649 end if; 650 651 Next_Non_Pragma (Handler); 652 end loop; 653 654 -- Nothing to do if no handlers requiring the goto transformation 655 656 if not (Local_Expansion_Required) then 657 return; 658 end if; 659 660 -- Prepare to do the transformation 661 662 declare 663 -- L3 is the label to exit the HSS 664 665 L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L'); 666 667 Labl_L3 : constant Node_Id := 668 Make_Label (Loc, 669 Identifier => New_Occurrence_Of (L3_Dent, Loc)); 670 671 Blk_Stm : Node_Id; 672 Relmt : Elmt_Id; 673 674 begin 675 Set_Exception_Junk (Labl_L3); 676 Add_Label_Declaration (L3_Dent); 677 678 -- Wrap existing statements and handlers in an inner block 679 680 Blk_Stm := 681 Make_Block_Statement (Loc, 682 Handled_Statement_Sequence => Relocate_Node (HSS)); 683 Set_Exception_Junk (Blk_Stm); 684 685 Rewrite (HSS, 686 Make_Handled_Sequence_Of_Statements (Loc, 687 Statements => New_List (Blk_Stm), 688 End_Label => Relocate_Node (End_Label (HSS)))); 689 690 -- Set block statement as analyzed, we don't want to actually call 691 -- Analyze on this block, it would cause a recursion in exception 692 -- handler processing which would mess things up. 693 694 Set_Analyzed (Blk_Stm); 695 696 -- Now loop through the exception handlers to deal with those that 697 -- are targets of local raise statements. 698 699 Handler := First_Non_Pragma (Handlrs); 700 while Present (Handler) loop 701 if Present (Exception_Label (Handler)) then 702 703 -- This handler needs the goto expansion 704 705 declare 706 Loc : constant Source_Ptr := Sloc (Handler); 707 708 -- L1 is the start label for this handler 709 710 L1_Dent : constant Entity_Id := Exception_Label (Handler); 711 712 Labl_L1 : constant Node_Id := 713 Make_Label (Loc, 714 Identifier => 715 New_Occurrence_Of (L1_Dent, Loc)); 716 717 -- Jump to L1 to be used as replacement for the original 718 -- handler (used in the case where exception propagation 719 -- may still occur). 720 721 Name_L1 : constant Node_Id := 722 New_Occurrence_Of (L1_Dent, Loc); 723 724 Goto_L1 : constant Node_Id := 725 Make_Goto_Statement (Loc, 726 Name => Name_L1); 727 728 -- Jump to L3 to be used at the end of handler 729 730 Name_L3 : constant Node_Id := 731 New_Occurrence_Of (L3_Dent, Loc); 732 733 Goto_L3 : constant Node_Id := 734 Make_Goto_Statement (Loc, 735 Name => Name_L3); 736 737 H_Stmts : constant List_Id := Statements (Handler); 738 739 begin 740 Set_Exception_Junk (Labl_L1); 741 Set_Exception_Junk (Goto_L3); 742 743 -- Note: we do NOT set Exception_Junk in Goto_L1, since 744 -- this is a real transfer of control that we want the 745 -- Sem_Ch6.Check_Returns procedure to recognize properly. 746 747 -- Replace handler by a goto L1. We can mark this as 748 -- analyzed since it is fully formed, and we don't 749 -- want it going through any further checks. We save 750 -- the last statement location in the goto L1 node for 751 -- the benefit of Sem_Ch6.Check_Returns. 752 753 Set_Statements (Handler, New_List (Goto_L1)); 754 Set_Analyzed (Goto_L1); 755 Set_Etype (Name_L1, Standard_Void_Type); 756 757 -- Now replace all the raise statements by goto L1 758 759 if Present (Local_Raise_Statements (Handler)) then 760 Relmt := First_Elmt (Local_Raise_Statements (Handler)); 761 while Present (Relmt) loop 762 declare 763 Raise_S : constant Node_Id := Node (Relmt); 764 RLoc : constant Source_Ptr := Sloc (Raise_S); 765 Name_L1 : constant Node_Id := 766 New_Occurrence_Of (L1_Dent, Loc); 767 Goto_L1 : constant Node_Id := 768 Make_Goto_Statement (RLoc, 769 Name => Name_L1); 770 771 begin 772 -- Replace raise by goto L1 773 774 Set_Analyzed (Goto_L1); 775 Set_Etype (Name_L1, Standard_Void_Type); 776 Replace_Raise_By_Goto (Raise_S, Goto_L1); 777 end; 778 779 Next_Elmt (Relmt); 780 end loop; 781 end if; 782 783 -- Add a goto L3 at end of statement list in block. The 784 -- first time, this is what skips over the exception 785 -- handlers in the normal case. Subsequent times, it 786 -- terminates the execution of the previous handler code, 787 -- and skips subsequent handlers. 788 789 Stmts := Statements (HSS); 790 791 Insert_After (Last (Stmts), Goto_L3); 792 Set_Analyzed (Goto_L3); 793 Set_Etype (Name_L3, Standard_Void_Type); 794 795 -- Now we drop the label that marks the handler start, 796 -- followed by the statements of the handler. 797 798 Set_Etype (Identifier (Labl_L1), Standard_Void_Type); 799 800 Insert_After_And_Analyze (Last (Stmts), Labl_L1); 801 802 declare 803 Loc : constant Source_Ptr := Sloc (First (H_Stmts)); 804 Blk : constant Node_Id := 805 Make_Block_Statement (Loc, 806 Handled_Statement_Sequence => 807 Make_Handled_Sequence_Of_Statements (Loc, 808 Statements => H_Stmts)); 809 begin 810 Set_Exception_Junk (Blk); 811 Insert_After_And_Analyze (Last (Stmts), Blk); 812 end; 813 end; 814 815 -- Here if we have local raise statements but the handler is 816 -- not suitable for processing with a local raise. In this 817 -- case we have to generate possible diagnostics. 818 819 elsif Has_Local_Raise (Handler) 820 and then Local_Raise_Statements (Handler) /= No_Elist 821 then 822 Relmt := First_Elmt (Local_Raise_Statements (Handler)); 823 while Present (Relmt) loop 824 Warn_If_No_Propagation (Node (Relmt)); 825 Next_Elmt (Relmt); 826 end loop; 827 end if; 828 829 Next (Handler); 830 end loop; 831 832 -- Only remaining step is to drop the L3 label and we are done 833 834 Set_Etype (Identifier (Labl_L3), Standard_Void_Type); 835 836 -- If we had at least one handler, then we drop the label after 837 -- the last statement of that handler. 838 839 if Stmts /= No_List then 840 Insert_After_And_Analyze (Last (Stmts), Labl_L3); 841 842 -- Otherwise we have removed all the handlers (this results from 843 -- use of pragma Restrictions (No_Exception_Propagation), and we 844 -- drop the label at the end of the statements of the HSS. 845 846 else 847 Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3); 848 end if; 849 850 return; 851 end; 852 end Expand_Local_Exception_Handlers; 853 854 ----------------------------- 855 -- Prepend_Call_To_Handler -- 856 ----------------------------- 857 858 procedure Prepend_Call_To_Handler 859 (Proc : RE_Id; 860 Args : List_Id := No_List) 861 is 862 Ent : constant Entity_Id := RTE (Proc); 863 864 begin 865 -- If we have no Entity, then we are probably in no run time mode or 866 -- some weird error has occurred. In either case do nothing. Note use 867 -- of No_Location to hide this code from the debugger, so single 868 -- stepping doesn't jump back and forth. 869 870 if Present (Ent) then 871 declare 872 Call : constant Node_Id := 873 Make_Procedure_Call_Statement (No_Location, 874 Name => New_Occurrence_Of (RTE (Proc), No_Location), 875 Parameter_Associations => Args); 876 877 begin 878 Prepend_To (Statements (Handler), Call); 879 Analyze (Call, Suppress => All_Checks); 880 end; 881 end if; 882 end Prepend_Call_To_Handler; 883 884 --------------------------- 885 -- Replace_Raise_By_Goto -- 886 --------------------------- 887 888 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is 889 Loc : constant Source_Ptr := Sloc (Raise_S); 890 Excep : Entity_Id; 891 LR : Node_Id; 892 Cond : Node_Id; 893 Orig : Node_Id; 894 895 begin 896 -- If we have a null statement, it means that there is no replacement 897 -- needed (typically this results from a suppressed check). 898 899 if Nkind (Raise_S) = N_Null_Statement then 900 return; 901 902 -- Test for Raise_xxx_Error 903 904 elsif Nkind (Raise_S) = N_Raise_Constraint_Error then 905 Excep := Standard_Constraint_Error; 906 Cond := Condition (Raise_S); 907 908 elsif Nkind (Raise_S) = N_Raise_Storage_Error then 909 Excep := Standard_Storage_Error; 910 Cond := Condition (Raise_S); 911 912 elsif Nkind (Raise_S) = N_Raise_Program_Error then 913 Excep := Standard_Program_Error; 914 Cond := Condition (Raise_S); 915 916 -- The only other possibility is a node that is or used to be a 917 -- simple raise statement. Note that the string expression in the 918 -- original Raise statement is ignored. 919 920 else 921 Orig := Original_Node (Raise_S); 922 pragma Assert (Nkind (Orig) = N_Raise_Statement 923 and then Present (Name (Orig))); 924 Excep := Entity (Name (Orig)); 925 Cond := Empty; 926 end if; 927 928 -- Here Excep is the exception to raise, and Cond is the condition 929 -- First prepare the call to Local_Raise (excep'address). 930 931 if RTE_Available (RE_Local_Raise) then 932 LR := 933 Make_Procedure_Call_Statement (Loc, 934 Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc), 935 Parameter_Associations => New_List ( 936 Unchecked_Convert_To (RTE (RE_Address), 937 Make_Attribute_Reference (Loc, 938 Prefix => New_Occurrence_Of (Excep, Loc), 939 Attribute_Name => Name_Identity)))); 940 941 -- Use null statement if Local_Raise not available 942 943 else 944 LR := 945 Make_Null_Statement (Loc); 946 end if; 947 948 -- If there is no condition, we rewrite as 949 950 -- begin 951 -- Local_Raise (excep'Identity); 952 -- goto L1; 953 -- end; 954 955 if No (Cond) then 956 Rewrite (Raise_S, 957 Make_Block_Statement (Loc, 958 Handled_Statement_Sequence => 959 Make_Handled_Sequence_Of_Statements (Loc, 960 Statements => New_List (LR, Goto_L1)))); 961 Set_Exception_Junk (Raise_S); 962 963 -- If there is a condition, we rewrite as 964 965 -- if condition then 966 -- Local_Raise (excep'Identity); 967 -- goto L1; 968 -- end if; 969 970 else 971 Rewrite (Raise_S, 972 Make_If_Statement (Loc, 973 Condition => Cond, 974 Then_Statements => New_List (LR, Goto_L1))); 975 end if; 976 977 Analyze (Raise_S); 978 end Replace_Raise_By_Goto; 979 980 -- Start of processing for Expand_Exception_Handlers 981 982 begin 983 Expand_Local_Exception_Handlers; 984 985 -- Loop through handlers 986 987 Handler := First_Non_Pragma (Handlrs); 988 Handler_Loop : while Present (Handler) loop 989 Process_Statements_For_Controlled_Objects (Handler); 990 991 Next_Handler := Next_Non_Pragma (Handler); 992 993 -- Remove source handler if gnat debug flag .x is set 994 995 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then 996 Remove (Handler); 997 998 -- Remove handler if no exception propagation, generating a warning 999 -- if a source generated handler was not the target of a local raise. 1000 1001 else 1002 if not Has_Local_Raise (Handler) 1003 and then Comes_From_Source (Handler) 1004 then 1005 Warn_If_No_Local_Raise (Handler); 1006 end if; 1007 1008 if No_Exception_Propagation_Active then 1009 Remove (Handler); 1010 1011 -- Exception handler is active and retained and must be processed 1012 1013 else 1014 -- If an exception occurrence is present, then we must declare 1015 -- it and initialize it from the value stored in the TSD 1016 1017 -- declare 1018 -- name : Exception_Occurrence; 1019 -- begin 1020 -- Save_Occurrence (name, Get_Current_Excep.all) 1021 -- ... 1022 -- end; 1023 1024 -- This expansion is only performed when using front-end 1025 -- exceptions. Gigi will insert a call to initialize the 1026 -- choice parameter. 1027 1028 if Present (Choice_Parameter (Handler)) 1029 and then (Front_End_Exceptions 1030 or else CodePeer_Mode) 1031 then 1032 declare 1033 Cparm : constant Entity_Id := Choice_Parameter (Handler); 1034 Cloc : constant Source_Ptr := Sloc (Cparm); 1035 Hloc : constant Source_Ptr := Sloc (Handler); 1036 Save : Node_Id; 1037 1038 begin 1039 -- Note: No_Location used to hide code from the debugger, 1040 -- so single stepping doesn't jump back and forth. 1041 1042 Save := 1043 Make_Procedure_Call_Statement (No_Location, 1044 Name => 1045 New_Occurrence_Of 1046 (RTE (RE_Save_Occurrence), No_Location), 1047 Parameter_Associations => New_List ( 1048 New_Occurrence_Of (Cparm, No_Location), 1049 Make_Explicit_Dereference (No_Location, 1050 Prefix => 1051 Make_Function_Call (No_Location, 1052 Name => 1053 Make_Explicit_Dereference (No_Location, 1054 Prefix => 1055 New_Occurrence_Of 1056 (RTE (RE_Get_Current_Excep), 1057 No_Location)))))); 1058 1059 Mark_Rewrite_Insertion (Save); 1060 Prepend (Save, Statements (Handler)); 1061 1062 Obj_Decl := 1063 Make_Object_Declaration (Cloc, 1064 Defining_Identifier => Cparm, 1065 Object_Definition => 1066 New_Occurrence_Of 1067 (RTE (RE_Exception_Occurrence), Cloc)); 1068 Set_No_Initialization (Obj_Decl, True); 1069 1070 Rewrite (Handler, 1071 Make_Exception_Handler (Hloc, 1072 Choice_Parameter => Empty, 1073 Exception_Choices => Exception_Choices (Handler), 1074 Statements => New_List ( 1075 Make_Block_Statement (Hloc, 1076 Declarations => New_List (Obj_Decl), 1077 Handled_Statement_Sequence => 1078 Make_Handled_Sequence_Of_Statements (Hloc, 1079 Statements => Statements (Handler)))))); 1080 1081 -- Local raise statements can't occur, since exception 1082 -- handlers with choice parameters are not allowed when 1083 -- No_Exception_Propagation applies, so set attributes 1084 -- accordingly. 1085 1086 Set_Local_Raise_Statements (Handler, No_Elist); 1087 Set_Local_Raise_Not_OK (Handler); 1088 1089 Analyze_List 1090 (Statements (Handler), Suppress => All_Checks); 1091 end; 1092 end if; 1093 1094 -- For the normal case, we have to worry about the state of 1095 -- abort deferral. Generally, we defer abort during runtime 1096 -- handling of exceptions. When control is passed to the 1097 -- handler, then in the normal case we undefer aborts. In 1098 -- any case this entire handling is relevant only if aborts 1099 -- are allowed. 1100 1101 if Abort_Allowed 1102 and then not ZCX_Exceptions 1103 then 1104 -- There are some special cases in which we do not do the 1105 -- undefer. In particular a finalization (AT END) handler 1106 -- wants to operate with aborts still deferred. 1107 1108 -- We also suppress the call if this is the special handler 1109 -- for Abort_Signal, since if we are aborting, we want to 1110 -- keep aborts deferred (one abort is enough). 1111 1112 -- If abort really needs to be deferred the expander must 1113 -- add this call explicitly, see 1114 -- Expand_N_Asynchronous_Select. 1115 1116 Others_Choice := 1117 Nkind (First (Exception_Choices (Handler))) = 1118 N_Others_Choice; 1119 1120 if (Others_Choice 1121 or else Entity (First (Exception_Choices (Handler))) /= 1122 Stand.Abort_Signal) 1123 and then not 1124 (Others_Choice 1125 and then 1126 All_Others (First (Exception_Choices (Handler)))) 1127 then 1128 Prepend_Call_To_Handler (RE_Abort_Undefer); 1129 end if; 1130 end if; 1131 end if; 1132 end if; 1133 1134 Handler := Next_Handler; 1135 end loop Handler_Loop; 1136 1137 -- If all handlers got removed, then remove the list. Note we cannot 1138 -- reference HSS here, since expanding local handlers may have buried 1139 -- the handlers in an inner block. 1140 1141 if Is_Empty_List (Handlrs) then 1142 Set_Exception_Handlers (Parent (Handlrs), No_List); 1143 end if; 1144 end Expand_Exception_Handlers; 1145 1146 ------------------------------------ 1147 -- Expand_N_Exception_Declaration -- 1148 ------------------------------------ 1149 1150 -- Generates: 1151 -- exceptE : constant String := "A.B.EXCEP"; -- static data 1152 -- except : exception_data := 1153 -- (Handled_By_Other => False, 1154 -- Lang => 'A', 1155 -- Name_Length => exceptE'Length, 1156 -- Full_Name => exceptE'Address, 1157 -- HTable_Ptr => null, 1158 -- Foreign_Data => null, 1159 -- Raise_Hook => null); 1160 1161 -- (protecting test only needed if not at library level) 1162 1163 -- exceptF : Boolean := True -- static data 1164 -- if exceptF then 1165 -- exceptF := False; 1166 -- Register_Exception (except'Unchecked_Access); 1167 -- end if; 1168 1169 procedure Expand_N_Exception_Declaration (N : Node_Id) is 1170 Id : constant Entity_Id := Defining_Identifier (N); 1171 Loc : constant Source_Ptr := Sloc (N); 1172 1173 procedure Force_Static_Allocation_Of_Referenced_Objects 1174 (Aggregate : Node_Id); 1175 -- A specialized solution to one particular case of an ugly problem 1176 -- 1177 -- The given aggregate includes an Unchecked_Conversion as one of the 1178 -- component values. The call to Analyze_And_Resolve below ends up 1179 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide 1180 -- to introduce a (constant) temporary and then obtain the component 1181 -- value by evaluating the temporary. 1182 -- 1183 -- In the case of an exception declared within a subprogram (or any 1184 -- other dynamic scope), this is a bad transformation. The exception 1185 -- object is marked as being Statically_Allocated but the temporary is 1186 -- not. If the initial value of a Statically_Allocated declaration 1187 -- references a dynamically allocated object, this prevents static 1188 -- initialization of the object. 1189 -- 1190 -- We cope with this here by marking the temporary Statically_Allocated. 1191 -- It might seem cleaner to generalize this utility and then use it to 1192 -- enforce a rule that the entities referenced in the declaration of any 1193 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) 1194 -- entity must also be either Library_Level or hoisted. It turns out 1195 -- that this would be incompatible with the current treatment of an 1196 -- object which is local to a subprogram, subject to an Export pragma, 1197 -- not subject to an address clause, and whose declaration contains 1198 -- references to other local (non-hoisted) objects (e.g., in the initial 1199 -- value expression). 1200 1201 function Null_String return String_Id; 1202 -- Build a null-terminated empty string 1203 1204 --------------------------------------------------- 1205 -- Force_Static_Allocation_Of_Referenced_Objects -- 1206 --------------------------------------------------- 1207 1208 procedure Force_Static_Allocation_Of_Referenced_Objects 1209 (Aggregate : Node_Id) 1210 is 1211 function Fixup_Node (N : Node_Id) return Traverse_Result; 1212 -- If the given node references a dynamically allocated object, then 1213 -- correct the declaration of the object. 1214 1215 ---------------- 1216 -- Fixup_Node -- 1217 ---------------- 1218 1219 function Fixup_Node (N : Node_Id) return Traverse_Result is 1220 begin 1221 if Nkind (N) in N_Has_Entity 1222 and then Present (Entity (N)) 1223 and then not Is_Library_Level_Entity (Entity (N)) 1224 1225 -- Note: the following test is not needed but it seems cleaner 1226 -- to do this test (this would be more important if procedure 1227 -- Force_Static_Allocation_Of_Referenced_Objects recursively 1228 -- traversed the declaration of an entity after marking it as 1229 -- statically allocated). 1230 1231 and then not Is_Statically_Allocated (Entity (N)) 1232 then 1233 Set_Is_Statically_Allocated (Entity (N)); 1234 end if; 1235 1236 return OK; 1237 end Fixup_Node; 1238 1239 procedure Fixup_Tree is new Traverse_Proc (Fixup_Node); 1240 1241 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects 1242 1243 begin 1244 Fixup_Tree (Aggregate); 1245 end Force_Static_Allocation_Of_Referenced_Objects; 1246 1247 ----------------- 1248 -- Null_String -- 1249 ----------------- 1250 1251 function Null_String return String_Id is 1252 begin 1253 Start_String; 1254 Store_String_Char (Get_Char_Code (ASCII.NUL)); 1255 return End_String; 1256 end Null_String; 1257 1258 -- Local variables 1259 1260 Ex_Id : Entity_Id; 1261 Ex_Val : String_Id; 1262 Flag_Id : Entity_Id; 1263 L : List_Id; 1264 1265 -- Start of processing for Expand_N_Exception_Declaration 1266 1267 begin 1268 -- Nothing to do when generating C code 1269 1270 if Modify_Tree_For_C then 1271 return; 1272 end if; 1273 1274 -- Definition of the external name: nam : constant String := "A.B.NAME"; 1275 1276 Ex_Id := 1277 Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E')); 1278 1279 -- Do not generate an external name if the exception declaration is 1280 -- subject to pragma Discard_Names. Use a null-terminated empty name 1281 -- to ensure that Ada.Exceptions.Exception_Name functions properly. 1282 1283 if Global_Discard_Names or else Discard_Names (Ex_Id) then 1284 Ex_Val := Null_String; 1285 1286 -- Otherwise generate the fully qualified name of the exception 1287 1288 else 1289 Ex_Val := Fully_Qualified_Name_String (Id); 1290 end if; 1291 1292 Insert_Action (N, 1293 Make_Object_Declaration (Loc, 1294 Defining_Identifier => Ex_Id, 1295 Constant_Present => True, 1296 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1297 Expression => Make_String_Literal (Loc, Ex_Val))); 1298 1299 Set_Is_Statically_Allocated (Ex_Id); 1300 1301 -- Create the aggregate list for type Standard.Exception_Type: 1302 -- Handled_By_Other component: False 1303 1304 L := Empty_List; 1305 Append_To (L, New_Occurrence_Of (Standard_False, Loc)); 1306 1307 -- Lang component: 'A' 1308 1309 Append_To (L, 1310 Make_Character_Literal (Loc, 1311 Chars => Name_uA, 1312 Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); 1313 1314 -- Name_Length component: Nam'Length 1315 1316 Append_To (L, 1317 Make_Attribute_Reference (Loc, 1318 Prefix => New_Occurrence_Of (Ex_Id, Loc), 1319 Attribute_Name => Name_Length)); 1320 1321 -- Full_Name component: Standard.A_Char!(Nam'Address) 1322 1323 -- The unchecked conversion causes capacity issues for CodePeer in some 1324 -- cases and is never useful, so we set the Full_Name component to null 1325 -- instead for CodePeer. 1326 1327 if CodePeer_Mode then 1328 Append_To (L, Make_Null (Loc)); 1329 else 1330 Append_To (L, Unchecked_Convert_To (Standard_A_Char, 1331 Make_Attribute_Reference (Loc, 1332 Prefix => New_Occurrence_Of (Ex_Id, Loc), 1333 Attribute_Name => Name_Address))); 1334 end if; 1335 1336 -- HTable_Ptr component: null 1337 1338 Append_To (L, Make_Null (Loc)); 1339 1340 -- Foreign_Data component: null 1341 1342 Append_To (L, Make_Null (Loc)); 1343 1344 -- Raise_Hook component: null 1345 1346 Append_To (L, Make_Null (Loc)); 1347 1348 Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); 1349 Analyze_And_Resolve (Expression (N), Etype (Id)); 1350 1351 Force_Static_Allocation_Of_Referenced_Objects (Expression (N)); 1352 1353 -- Register_Exception (except'Unchecked_Access); 1354 1355 if not No_Exception_Handlers_Set 1356 and then not Restriction_Active (No_Exception_Registration) 1357 then 1358 L := New_List ( 1359 Make_Procedure_Call_Statement (Loc, 1360 Name => 1361 New_Occurrence_Of (RTE (RE_Register_Exception), Loc), 1362 Parameter_Associations => New_List ( 1363 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), 1364 Make_Attribute_Reference (Loc, 1365 Prefix => New_Occurrence_Of (Id, Loc), 1366 Attribute_Name => Name_Unrestricted_Access))))); 1367 1368 Set_Register_Exception_Call (Id, First (L)); 1369 1370 if not Is_Library_Level_Entity (Id) then 1371 Flag_Id := 1372 Make_Defining_Identifier (Loc, 1373 Chars => New_External_Name (Chars (Id), 'F')); 1374 1375 Insert_Action (N, 1376 Make_Object_Declaration (Loc, 1377 Defining_Identifier => Flag_Id, 1378 Object_Definition => 1379 New_Occurrence_Of (Standard_Boolean, Loc), 1380 Expression => 1381 New_Occurrence_Of (Standard_True, Loc))); 1382 1383 Set_Is_Statically_Allocated (Flag_Id); 1384 1385 Append_To (L, 1386 Make_Assignment_Statement (Loc, 1387 Name => New_Occurrence_Of (Flag_Id, Loc), 1388 Expression => New_Occurrence_Of (Standard_False, Loc))); 1389 1390 Insert_After_And_Analyze (N, 1391 Make_Implicit_If_Statement (N, 1392 Condition => New_Occurrence_Of (Flag_Id, Loc), 1393 Then_Statements => L)); 1394 1395 else 1396 Insert_List_After_And_Analyze (N, L); 1397 end if; 1398 end if; 1399 end Expand_N_Exception_Declaration; 1400 1401 --------------------------------------------- 1402 -- Expand_N_Handled_Sequence_Of_Statements -- 1403 --------------------------------------------- 1404 1405 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is 1406 begin 1407 -- Expand exception handlers 1408 1409 if Present (Exception_Handlers (N)) 1410 and then not Restriction_Active (No_Exception_Handlers) 1411 then 1412 Expand_Exception_Handlers (N); 1413 end if; 1414 1415 -- If local exceptions are being expanded, the previous call will 1416 -- have rewritten the construct as a block and reanalyzed it. No 1417 -- further expansion is needed. 1418 1419 if Analyzed (N) then 1420 return; 1421 end if; 1422 1423 -- Add cleanup actions if required. No cleanup actions are needed in 1424 -- thunks associated with interfaces, because they only displace the 1425 -- pointer to the object. For extended return statements, we need 1426 -- cleanup actions if the Handled_Statement_Sequence contains generated 1427 -- objects of controlled types, for example. We do not want to clean up 1428 -- the return object. 1429 1430 if not Nkind_In (Parent (N), N_Accept_Statement, 1431 N_Extended_Return_Statement, 1432 N_Package_Body) 1433 and then not Delay_Cleanups (Current_Scope) 1434 and then not Is_Thunk (Current_Scope) 1435 then 1436 Expand_Cleanup_Actions (Parent (N)); 1437 1438 elsif Nkind (Parent (N)) = N_Extended_Return_Statement 1439 and then Handled_Statement_Sequence (Parent (N)) = N 1440 and then not Delay_Cleanups (Current_Scope) 1441 then 1442 pragma Assert (not Is_Thunk (Current_Scope)); 1443 Expand_Cleanup_Actions (Parent (N)); 1444 1445 else 1446 Set_First_Real_Statement (N, First (Statements (N))); 1447 end if; 1448 end Expand_N_Handled_Sequence_Of_Statements; 1449 1450 ------------------------------------- 1451 -- Expand_N_Raise_Constraint_Error -- 1452 ------------------------------------- 1453 1454 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is 1455 begin 1456 -- We adjust the condition to deal with the C/Fortran boolean case. This 1457 -- may well not be necessary, as all such conditions are generated by 1458 -- the expander and probably are all standard boolean, but who knows 1459 -- what strange optimization in future may require this adjustment. 1460 1461 Adjust_Condition (Condition (N)); 1462 1463 -- Now deal with possible local raise handling 1464 1465 Possible_Local_Raise (N, Standard_Constraint_Error); 1466 end Expand_N_Raise_Constraint_Error; 1467 1468 ------------------------------- 1469 -- Expand_N_Raise_Expression -- 1470 ------------------------------- 1471 1472 procedure Expand_N_Raise_Expression (N : Node_Id) is 1473 Loc : constant Source_Ptr := Sloc (N); 1474 Typ : constant Entity_Id := Etype (N); 1475 RCE : Node_Id; 1476 1477 begin 1478 Possible_Local_Raise (N, Entity (Name (N))); 1479 1480 -- Later we must teach the back end/gigi how to deal with this, but 1481 -- for now we will assume the type is Standard_Boolean and transform 1482 -- the node to: 1483 1484 -- do 1485 -- raise X [with string] 1486 -- in 1487 -- raise Constraint_Error; 1488 1489 -- unless the flag Convert_To_Return_False is set, in which case 1490 -- the transformation is to: 1491 1492 -- do 1493 -- return False; 1494 -- in 1495 -- raise Constraint_Error; 1496 1497 -- The raise constraint error can never be executed. It is just a dummy 1498 -- node that can be labeled with an arbitrary type. 1499 1500 RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); 1501 Set_Etype (RCE, Typ); 1502 1503 if Convert_To_Return_False (N) then 1504 Rewrite (N, 1505 Make_Expression_With_Actions (Loc, 1506 Actions => New_List ( 1507 Make_Simple_Return_Statement (Loc, 1508 Expression => New_Occurrence_Of (Standard_False, Loc))), 1509 Expression => RCE)); 1510 1511 else 1512 Rewrite (N, 1513 Make_Expression_With_Actions (Loc, 1514 Actions => New_List ( 1515 Make_Raise_Statement (Loc, 1516 Name => Name (N), 1517 Expression => Expression (N))), 1518 Expression => RCE)); 1519 end if; 1520 1521 Analyze_And_Resolve (N, Typ); 1522 end Expand_N_Raise_Expression; 1523 1524 ---------------------------------- 1525 -- Expand_N_Raise_Program_Error -- 1526 ---------------------------------- 1527 1528 procedure Expand_N_Raise_Program_Error (N : Node_Id) is 1529 begin 1530 -- We adjust the condition to deal with the C/Fortran boolean case. This 1531 -- may well not be necessary, as all such conditions are generated by 1532 -- the expander and probably are all standard boolean, but who knows 1533 -- what strange optimization in future may require this adjustment. 1534 1535 Adjust_Condition (Condition (N)); 1536 1537 -- Now deal with possible local raise handling 1538 1539 Possible_Local_Raise (N, Standard_Program_Error); 1540 end Expand_N_Raise_Program_Error; 1541 1542 ------------------------------ 1543 -- Expand_N_Raise_Statement -- 1544 ------------------------------ 1545 1546 procedure Expand_N_Raise_Statement (N : Node_Id) is 1547 Loc : constant Source_Ptr := Sloc (N); 1548 Ehand : Node_Id; 1549 E : Entity_Id; 1550 Str : String_Id; 1551 H : Node_Id; 1552 Src : Boolean; 1553 1554 begin 1555 -- Processing for locally handled exception (exclude reraise case) 1556 1557 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then 1558 if Debug_Flag_Dot_G 1559 or else Restriction_Active (No_Exception_Propagation) 1560 then 1561 -- If we have a local handler, then note that this is potentially 1562 -- able to be transformed into a goto statement. 1563 1564 H := Find_Local_Handler (Entity (Name (N)), N); 1565 1566 if Present (H) then 1567 if Local_Raise_Statements (H) = No_Elist then 1568 Set_Local_Raise_Statements (H, New_Elmt_List); 1569 end if; 1570 1571 -- Append the new entry if it is not there already. Sometimes 1572 -- we have situations where due to reexpansion, the same node 1573 -- is analyzed twice and would otherwise be added twice. 1574 1575 Append_Unique_Elmt (N, Local_Raise_Statements (H)); 1576 Set_Has_Local_Raise (H); 1577 1578 -- If no local handler, then generate no propagation warning 1579 1580 else 1581 Warn_If_No_Propagation (N); 1582 end if; 1583 1584 end if; 1585 end if; 1586 1587 -- If a string expression is present, then the raise statement is 1588 -- converted to a call: 1589 -- Raise_Exception (exception-name'Identity, string); 1590 -- and there is nothing else to do. 1591 1592 if Present (Expression (N)) then 1593 1594 -- Adjust message to deal with Prefix_Exception_Messages. We only 1595 -- add the prefix to string literals, if the message is being 1596 -- constructed, we assume it already deals with uniqueness. 1597 1598 if Prefix_Exception_Messages 1599 and then Nkind (Expression (N)) = N_String_Literal 1600 then 1601 declare 1602 Buf : Bounded_String; 1603 begin 1604 Add_Source_Info (Buf, Loc, Name_Enclosing_Entity); 1605 Append (Buf, ": "); 1606 Append (Buf, Strval (Expression (N))); 1607 Rewrite (Expression (N), Make_String_Literal (Loc, +Buf)); 1608 Analyze_And_Resolve (Expression (N), Standard_String); 1609 end; 1610 end if; 1611 1612 -- Avoid passing exception-name'identity in runtimes in which this 1613 -- argument is not used. This avoids generating undefined references 1614 -- to these exceptions when compiling with no optimization 1615 1616 if Configurable_Run_Time_On_Target 1617 and then (Restriction_Active (No_Exception_Handlers) 1618 or else 1619 Restriction_Active (No_Exception_Propagation)) 1620 then 1621 Rewrite (N, 1622 Make_Procedure_Call_Statement (Loc, 1623 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1624 Parameter_Associations => New_List ( 1625 New_Occurrence_Of (RTE (RE_Null_Id), Loc), 1626 Expression (N)))); 1627 else 1628 Rewrite (N, 1629 Make_Procedure_Call_Statement (Loc, 1630 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1631 Parameter_Associations => New_List ( 1632 Make_Attribute_Reference (Loc, 1633 Prefix => Name (N), 1634 Attribute_Name => Name_Identity), 1635 Expression (N)))); 1636 end if; 1637 1638 Analyze (N); 1639 return; 1640 end if; 1641 1642 -- Remaining processing is for the case where no string expression is 1643 -- present. 1644 1645 -- Don't expand a raise statement that does not come from source if we 1646 -- have already had configurable run-time violations, since most likely 1647 -- it will be junk cascaded nonsense. 1648 1649 if Configurable_Run_Time_Violations > 0 1650 and then not Comes_From_Source (N) 1651 then 1652 return; 1653 end if; 1654 1655 -- Convert explicit raise of Program_Error, Constraint_Error, and 1656 -- Storage_Error into the corresponding raise (in High_Integrity_Mode 1657 -- all other raises will get normal expansion and be disallowed, 1658 -- but this is also faster in all modes). Propagate Comes_From_Source 1659 -- flag to the new node. 1660 1661 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then 1662 Src := Comes_From_Source (N); 1663 1664 if Entity (Name (N)) = Standard_Constraint_Error then 1665 Rewrite (N, 1666 Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise)); 1667 Set_Comes_From_Source (N, Src); 1668 Analyze (N); 1669 return; 1670 1671 elsif Entity (Name (N)) = Standard_Program_Error then 1672 Rewrite (N, 1673 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); 1674 Set_Comes_From_Source (N, Src); 1675 Analyze (N); 1676 return; 1677 1678 elsif Entity (Name (N)) = Standard_Storage_Error then 1679 Rewrite (N, 1680 Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise)); 1681 Set_Comes_From_Source (N, Src); 1682 Analyze (N); 1683 return; 1684 end if; 1685 end if; 1686 1687 -- Case of name present, in this case we expand raise name to 1688 1689 -- Raise_Exception (name'Identity, location_string); 1690 1691 -- where location_string identifies the file/line of the raise 1692 1693 if Present (Name (N)) then 1694 declare 1695 Id : Entity_Id := Entity (Name (N)); 1696 Buf : Bounded_String; 1697 1698 begin 1699 Build_Location_String (Buf, Loc); 1700 1701 -- If the exception is a renaming, use the exception that it 1702 -- renames (which might be a predefined exception, e.g.). 1703 1704 if Present (Renamed_Object (Id)) then 1705 Id := Renamed_Object (Id); 1706 end if; 1707 1708 -- Build a C-compatible string in case of no exception handlers, 1709 -- since this is what the last chance handler is expecting. 1710 1711 if No_Exception_Handlers_Set then 1712 1713 -- Generate an empty message if configuration pragma 1714 -- Suppress_Exception_Locations is set for this unit. 1715 1716 if Opt.Exception_Locations_Suppressed then 1717 Buf.Length := 0; 1718 end if; 1719 1720 Append (Buf, ASCII.NUL); 1721 end if; 1722 1723 if Opt.Exception_Locations_Suppressed then 1724 Buf.Length := 0; 1725 end if; 1726 1727 Str := String_From_Name_Buffer (Buf); 1728 1729 -- Convert raise to call to the Raise_Exception routine 1730 1731 Rewrite (N, 1732 Make_Procedure_Call_Statement (Loc, 1733 Name => 1734 New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1735 Parameter_Associations => New_List ( 1736 Make_Attribute_Reference (Loc, 1737 Prefix => Name (N), 1738 Attribute_Name => Name_Identity), 1739 Make_String_Literal (Loc, Strval => Str)))); 1740 end; 1741 1742 -- Case of no name present (reraise). We rewrite the raise to: 1743 1744 -- Reraise_Occurrence_Always (EO); 1745 1746 -- where EO is the current exception occurrence. If the current handler 1747 -- does not have a choice parameter specification, then we provide one. 1748 1749 else 1750 -- Bypass expansion to a run-time call when back-end exception 1751 -- handling is active, unless the target is CodePeer or GNATprove. 1752 -- In CodePeer, raising an exception is treated as an error, while in 1753 -- GNATprove all code with exceptions falls outside the subset of 1754 -- code which can be formally analyzed. 1755 1756 if not CodePeer_Mode 1757 and then Back_End_Exceptions 1758 then 1759 return; 1760 end if; 1761 1762 -- Find innermost enclosing exception handler (there must be one, 1763 -- since the semantics has already verified that this raise statement 1764 -- is valid, and a raise with no arguments is only permitted in the 1765 -- context of an exception handler. 1766 1767 Ehand := Parent (N); 1768 while Nkind (Ehand) /= N_Exception_Handler loop 1769 Ehand := Parent (Ehand); 1770 end loop; 1771 1772 -- Make exception choice parameter if none present. Note that we do 1773 -- not need to put the entity on the entity chain, since no one will 1774 -- be referencing this entity by normal visibility methods. 1775 1776 if No (Choice_Parameter (Ehand)) then 1777 E := Make_Temporary (Loc, 'E'); 1778 Set_Choice_Parameter (Ehand, E); 1779 Set_Ekind (E, E_Variable); 1780 Set_Etype (E, RTE (RE_Exception_Occurrence)); 1781 Set_Scope (E, Current_Scope); 1782 end if; 1783 1784 -- Now rewrite the raise as a call to Reraise. A special case arises 1785 -- if this raise statement occurs in the context of a handler for 1786 -- all others (i.e. an at end handler). in this case we avoid 1787 -- the call to defer abort, cleanup routines are expected to be 1788 -- called in this case with aborts deferred. 1789 1790 declare 1791 Ech : constant Node_Id := First (Exception_Choices (Ehand)); 1792 Ent : Entity_Id; 1793 1794 begin 1795 if Nkind (Ech) = N_Others_Choice 1796 and then All_Others (Ech) 1797 then 1798 Ent := RTE (RE_Reraise_Occurrence_No_Defer); 1799 else 1800 Ent := RTE (RE_Reraise_Occurrence_Always); 1801 end if; 1802 1803 Rewrite (N, 1804 Make_Procedure_Call_Statement (Loc, 1805 Name => New_Occurrence_Of (Ent, Loc), 1806 Parameter_Associations => New_List ( 1807 New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); 1808 end; 1809 end if; 1810 1811 Analyze (N); 1812 end Expand_N_Raise_Statement; 1813 1814 ---------------------------------- 1815 -- Expand_N_Raise_Storage_Error -- 1816 ---------------------------------- 1817 1818 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is 1819 begin 1820 -- We adjust the condition to deal with the C/Fortran boolean case. This 1821 -- may well not be necessary, as all such conditions are generated by 1822 -- the expander and probably are all standard boolean, but who knows 1823 -- what strange optimization in future may require this adjustment. 1824 1825 Adjust_Condition (Condition (N)); 1826 1827 -- Now deal with possible local raise handling 1828 1829 Possible_Local_Raise (N, Standard_Storage_Error); 1830 end Expand_N_Raise_Storage_Error; 1831 1832 -------------------------- 1833 -- Possible_Local_Raise -- 1834 -------------------------- 1835 1836 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is 1837 begin 1838 -- Nothing to do if local raise optimization not active 1839 1840 if not Debug_Flag_Dot_G 1841 and then not Restriction_Active (No_Exception_Propagation) 1842 then 1843 return; 1844 end if; 1845 1846 -- Nothing to do if original node was an explicit raise, because in 1847 -- that case, we already generated the required warning for the raise. 1848 1849 if Nkind (Original_Node (N)) = N_Raise_Statement then 1850 return; 1851 end if; 1852 1853 -- Otherwise see if we have a local handler for the exception 1854 1855 declare 1856 H : constant Node_Id := Find_Local_Handler (E, N); 1857 1858 begin 1859 -- If so, mark that it has a local raise 1860 1861 if Present (H) then 1862 Set_Has_Local_Raise (H, True); 1863 1864 -- Otherwise, if the No_Exception_Propagation restriction is active 1865 -- and the warning is enabled, generate the appropriate warnings. 1866 1867 -- ??? Do not do it for the Call_Marker nodes inserted by the ABE 1868 -- mechanism because this generates too many false positives, or 1869 -- for generic instantiations for the same reason. 1870 1871 elsif Warn_On_Non_Local_Exception 1872 and then Restriction_Active (No_Exception_Propagation) 1873 and then Nkind (N) /= N_Call_Marker 1874 and then Nkind (N) not in N_Generic_Instantiation 1875 then 1876 Warn_No_Exception_Propagation_Active (N); 1877 1878 if Configurable_Run_Time_Mode then 1879 Error_Msg_NE 1880 ("\?X?& may call Last_Chance_Handler", N, E); 1881 else 1882 Error_Msg_NE 1883 ("\?X?& may result in unhandled exception", N, E); 1884 end if; 1885 end if; 1886 end; 1887 end Possible_Local_Raise; 1888 1889 ------------------------ 1890 -- Find_Local_Handler -- 1891 ------------------------ 1892 1893 function Find_Local_Handler 1894 (Ename : Entity_Id; 1895 Nod : Node_Id) return Node_Id 1896 is 1897 N : Node_Id; 1898 P : Node_Id; 1899 H : Node_Id; 1900 C : Node_Id; 1901 1902 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 1903 -- This is used to test for wrapped actions below 1904 1905 ERaise : Entity_Id; 1906 EHandle : Entity_Id; 1907 -- The entity Id's for the exception we are raising and handling, using 1908 -- the renamed exception if a Renamed_Entity is present. 1909 1910 begin 1911 -- Never any local handler if all handlers removed 1912 1913 if Debug_Flag_Dot_X then 1914 return Empty; 1915 end if; 1916 1917 -- Get the exception we are raising, allowing for renaming 1918 1919 ERaise := Get_Renamed_Entity (Ename); 1920 1921 -- We need to check if the node we are looking at is contained in 1922 -- 1923 1924 -- Loop to search up the tree 1925 1926 N := Nod; 1927 loop 1928 P := Parent (N); 1929 1930 -- If we get to the top of the tree, or to a subprogram, task, entry, 1931 -- protected body, or accept statement without having found a 1932 -- matching handler, then there is no local handler. 1933 1934 if No (P) 1935 or else Nkind (P) = N_Subprogram_Body 1936 or else Nkind (P) = N_Task_Body 1937 or else Nkind (P) = N_Protected_Body 1938 or else Nkind (P) = N_Entry_Body 1939 or else Nkind (P) = N_Accept_Statement 1940 then 1941 return Empty; 1942 1943 -- Test for handled sequence of statements with at least one 1944 -- exception handler which might be the one we are looking for. 1945 1946 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 1947 and then Present (Exception_Handlers (P)) 1948 then 1949 -- Before we proceed we need to check if the node N is covered 1950 -- by the statement part of P rather than one of its exception 1951 -- handlers (an exception handler obviously does not cover its 1952 -- own statements). 1953 1954 -- This test is more delicate than might be thought. It is not 1955 -- just a matter of checking the Statements (P), because the node 1956 -- might be waiting to be wrapped in a transient scope, in which 1957 -- case it will end up in the block statements, even though it 1958 -- is not there now. 1959 1960 if Is_List_Member (N) then 1961 declare 1962 LCN : constant List_Id := List_Containing (N); 1963 1964 begin 1965 if LCN = Statements (P) 1966 or else 1967 LCN = SSE.Actions_To_Be_Wrapped (Before) 1968 or else 1969 LCN = SSE.Actions_To_Be_Wrapped (After) 1970 or else 1971 LCN = SSE.Actions_To_Be_Wrapped (Cleanup) 1972 then 1973 -- Loop through exception handlers 1974 1975 H := First (Exception_Handlers (P)); 1976 while Present (H) loop 1977 1978 -- Guard against other constructs appearing in the 1979 -- list of exception handlers. 1980 1981 if Nkind (H) = N_Exception_Handler then 1982 1983 -- Loop through choices in one handler 1984 1985 C := First (Exception_Choices (H)); 1986 while Present (C) loop 1987 1988 -- Deal with others case 1989 1990 if Nkind (C) = N_Others_Choice then 1991 1992 -- Matching others handler, but we need 1993 -- to ensure there is no choice parameter. 1994 -- If there is, then we don't have a local 1995 -- handler after all (since we do not allow 1996 -- choice parameters for local handlers). 1997 1998 if No (Choice_Parameter (H)) then 1999 return H; 2000 else 2001 return Empty; 2002 end if; 2003 2004 -- If not others must be entity name 2005 2006 elsif Nkind (C) /= N_Others_Choice then 2007 pragma Assert (Is_Entity_Name (C)); 2008 pragma Assert (Present (Entity (C))); 2009 2010 -- Get exception being handled, dealing with 2011 -- renaming. 2012 2013 EHandle := Get_Renamed_Entity (Entity (C)); 2014 2015 -- If match, then check choice parameter 2016 2017 if ERaise = EHandle then 2018 if No (Choice_Parameter (H)) then 2019 return H; 2020 else 2021 return Empty; 2022 end if; 2023 end if; 2024 end if; 2025 2026 Next (C); 2027 end loop; 2028 end if; 2029 2030 Next (H); 2031 end loop; 2032 end if; 2033 end; 2034 end if; 2035 end if; 2036 2037 N := P; 2038 end loop; 2039 end Find_Local_Handler; 2040 2041 --------------------------------- 2042 -- Get_Local_Raise_Call_Entity -- 2043 --------------------------------- 2044 2045 -- Note: this is primarily provided for use by the back end in generating 2046 -- calls to Local_Raise. But it would be too late in the back end to call 2047 -- RTE if this actually caused a load/analyze of the unit. So what we do 2048 -- is to ensure there is a dummy call to this function during front end 2049 -- processing so that the unit gets loaded then, and not later. 2050 2051 Local_Raise_Call_Entity : Entity_Id; 2052 Local_Raise_Call_Entity_Set : Boolean := False; 2053 2054 function Get_Local_Raise_Call_Entity return Entity_Id is 2055 begin 2056 if not Local_Raise_Call_Entity_Set then 2057 Local_Raise_Call_Entity_Set := True; 2058 2059 if RTE_Available (RE_Local_Raise) then 2060 Local_Raise_Call_Entity := RTE (RE_Local_Raise); 2061 else 2062 Local_Raise_Call_Entity := Empty; 2063 end if; 2064 end if; 2065 2066 return Local_Raise_Call_Entity; 2067 end Get_Local_Raise_Call_Entity; 2068 2069 ----------------------------- 2070 -- Get_RT_Exception_Entity -- 2071 ----------------------------- 2072 2073 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is 2074 begin 2075 case Rkind (R) is 2076 when CE_Reason => return Standard_Constraint_Error; 2077 when PE_Reason => return Standard_Program_Error; 2078 when SE_Reason => return Standard_Storage_Error; 2079 end case; 2080 end Get_RT_Exception_Entity; 2081 2082 --------------------------- 2083 -- Get_RT_Exception_Name -- 2084 --------------------------- 2085 2086 procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is 2087 begin 2088 case Code is 2089 when CE_Access_Check_Failed => 2090 Add_Str_To_Name_Buffer ("CE_Access_Check"); 2091 when CE_Access_Parameter_Is_Null => 2092 Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter"); 2093 when CE_Discriminant_Check_Failed => 2094 Add_Str_To_Name_Buffer ("CE_Discriminant_Check"); 2095 when CE_Divide_By_Zero => 2096 Add_Str_To_Name_Buffer ("CE_Divide_By_Zero"); 2097 when CE_Explicit_Raise => 2098 Add_Str_To_Name_Buffer ("CE_Explicit_Raise"); 2099 when CE_Index_Check_Failed => 2100 Add_Str_To_Name_Buffer ("CE_Index_Check"); 2101 when CE_Invalid_Data => 2102 Add_Str_To_Name_Buffer ("CE_Invalid_Data"); 2103 when CE_Length_Check_Failed => 2104 Add_Str_To_Name_Buffer ("CE_Length_Check"); 2105 when CE_Null_Exception_Id => 2106 Add_Str_To_Name_Buffer ("CE_Null_Exception_Id"); 2107 when CE_Null_Not_Allowed => 2108 Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed"); 2109 when CE_Overflow_Check_Failed => 2110 Add_Str_To_Name_Buffer ("CE_Overflow_Check"); 2111 when CE_Partition_Check_Failed => 2112 Add_Str_To_Name_Buffer ("CE_Partition_Check"); 2113 when CE_Range_Check_Failed => 2114 Add_Str_To_Name_Buffer ("CE_Range_Check"); 2115 when CE_Tag_Check_Failed => 2116 Add_Str_To_Name_Buffer ("CE_Tag_Check"); 2117 2118 when PE_Access_Before_Elaboration => 2119 Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration"); 2120 when PE_Accessibility_Check_Failed => 2121 Add_Str_To_Name_Buffer ("PE_Accessibility_Check"); 2122 when PE_Address_Of_Intrinsic => 2123 Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic"); 2124 when PE_Aliased_Parameters => 2125 Add_Str_To_Name_Buffer ("PE_Aliased_Parameters"); 2126 when PE_All_Guards_Closed => 2127 Add_Str_To_Name_Buffer ("PE_All_Guards_Closed"); 2128 when PE_Bad_Predicated_Generic_Type => 2129 Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type"); 2130 when PE_Build_In_Place_Mismatch => 2131 Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch"); 2132 when PE_Current_Task_In_Entry_Body => 2133 Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body"); 2134 when PE_Duplicated_Entry_Address => 2135 Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address"); 2136 when PE_Explicit_Raise => 2137 Add_Str_To_Name_Buffer ("PE_Explicit_Raise"); 2138 when PE_Finalize_Raised_Exception => 2139 Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception"); 2140 when PE_Implicit_Return => 2141 Add_Str_To_Name_Buffer ("PE_Implicit_Return"); 2142 when PE_Misaligned_Address_Value => 2143 Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value"); 2144 when PE_Missing_Return => 2145 Add_Str_To_Name_Buffer ("PE_Missing_Return"); 2146 when PE_Non_Transportable_Actual => 2147 Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); 2148 when PE_Overlaid_Controlled_Object => 2149 Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object"); 2150 when PE_Potentially_Blocking_Operation => 2151 Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation"); 2152 when PE_Stream_Operation_Not_Allowed => 2153 Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed"); 2154 when PE_Stubbed_Subprogram_Called => 2155 Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called"); 2156 when PE_Unchecked_Union_Restriction => 2157 Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction"); 2158 2159 when SE_Empty_Storage_Pool => 2160 Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool"); 2161 when SE_Explicit_Raise => 2162 Add_Str_To_Name_Buffer ("SE_Explicit_Raise"); 2163 when SE_Infinite_Recursion => 2164 Add_Str_To_Name_Buffer ("SE_Infinite_Recursion"); 2165 when SE_Object_Too_Large => 2166 Add_Str_To_Name_Buffer ("SE_Object_Too_Large"); 2167 end case; 2168 end Get_RT_Exception_Name; 2169 2170 ---------------------------- 2171 -- Warn_If_No_Local_Raise -- 2172 ---------------------------- 2173 2174 procedure Warn_If_No_Local_Raise (N : Node_Id) is 2175 begin 2176 if Restriction_Active (No_Exception_Propagation) 2177 and then Warn_On_Non_Local_Exception 2178 then 2179 Warn_No_Exception_Propagation_Active (N); 2180 2181 Error_Msg_N 2182 ("\?X?this handler can never be entered, and has been removed", N); 2183 end if; 2184 end Warn_If_No_Local_Raise; 2185 2186 ---------------------------- 2187 -- Warn_If_No_Propagation -- 2188 ---------------------------- 2189 2190 procedure Warn_If_No_Propagation (N : Node_Id) is 2191 begin 2192 if Restriction_Check_Required (No_Exception_Propagation) 2193 and then Warn_On_Non_Local_Exception 2194 then 2195 Warn_No_Exception_Propagation_Active (N); 2196 2197 if Configurable_Run_Time_Mode then 2198 Error_Msg_N 2199 ("\?X?Last_Chance_Handler will be called on exception", N); 2200 else 2201 Error_Msg_N 2202 ("\?X?execution may raise unhandled exception", N); 2203 end if; 2204 end if; 2205 end Warn_If_No_Propagation; 2206 2207 ------------------------------------------ 2208 -- Warn_No_Exception_Propagation_Active -- 2209 ------------------------------------------ 2210 2211 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is 2212 begin 2213 Error_Msg_N 2214 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N); 2215 end Warn_No_Exception_Propagation_Active; 2216 2217end Exp_Ch11; 2218