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