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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with 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 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. 918 919 else 920 Orig := Original_Node (Raise_S); 921 pragma Assert (Nkind (Orig) = N_Raise_Statement 922 and then Present (Name (Orig)) 923 and then No (Expression (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 Restriction_Active (No_Exception_Propagation) 1003 and then not Has_Local_Raise (Handler) 1004 and then Comes_From_Source (Handler) 1005 and then Warn_On_Non_Local_Exception 1006 then 1007 Warn_No_Exception_Propagation_Active (Handler); 1008 Error_Msg_N 1009 ("\?X?this handler can never be entered, " 1010 & "and has been removed", Handler); 1011 end if; 1012 1013 if No_Exception_Propagation_Active then 1014 Remove (Handler); 1015 1016 -- Exception handler is active and retained and must be processed 1017 1018 else 1019 -- If an exception occurrence is present, then we must declare 1020 -- it and initialize it from the value stored in the TSD 1021 1022 -- declare 1023 -- name : Exception_Occurrence; 1024 -- begin 1025 -- Save_Occurrence (name, Get_Current_Excep.all) 1026 -- ... 1027 -- end; 1028 1029 -- This expansion is only performed when using front-end 1030 -- exceptions. Gigi will insert a call to initialize the 1031 -- choice parameter. 1032 1033 if Present (Choice_Parameter (Handler)) 1034 and then (Front_End_Exceptions 1035 or else CodePeer_Mode) 1036 then 1037 declare 1038 Cparm : constant Entity_Id := Choice_Parameter (Handler); 1039 Cloc : constant Source_Ptr := Sloc (Cparm); 1040 Hloc : constant Source_Ptr := Sloc (Handler); 1041 Save : Node_Id; 1042 1043 begin 1044 -- Note: No_Location used to hide code from the debugger, 1045 -- so single stepping doesn't jump back and forth. 1046 1047 Save := 1048 Make_Procedure_Call_Statement (No_Location, 1049 Name => 1050 New_Occurrence_Of 1051 (RTE (RE_Save_Occurrence), No_Location), 1052 Parameter_Associations => New_List ( 1053 New_Occurrence_Of (Cparm, No_Location), 1054 Make_Explicit_Dereference (No_Location, 1055 Prefix => 1056 Make_Function_Call (No_Location, 1057 Name => 1058 Make_Explicit_Dereference (No_Location, 1059 Prefix => 1060 New_Occurrence_Of 1061 (RTE (RE_Get_Current_Excep), 1062 No_Location)))))); 1063 1064 Mark_Rewrite_Insertion (Save); 1065 Prepend (Save, Statements (Handler)); 1066 1067 Obj_Decl := 1068 Make_Object_Declaration (Cloc, 1069 Defining_Identifier => Cparm, 1070 Object_Definition => 1071 New_Occurrence_Of 1072 (RTE (RE_Exception_Occurrence), Cloc)); 1073 Set_No_Initialization (Obj_Decl, True); 1074 1075 Rewrite (Handler, 1076 Make_Exception_Handler (Hloc, 1077 Choice_Parameter => Empty, 1078 Exception_Choices => Exception_Choices (Handler), 1079 Statements => New_List ( 1080 Make_Block_Statement (Hloc, 1081 Declarations => New_List (Obj_Decl), 1082 Handled_Statement_Sequence => 1083 Make_Handled_Sequence_Of_Statements (Hloc, 1084 Statements => Statements (Handler)))))); 1085 1086 -- Local raise statements can't occur, since exception 1087 -- handlers with choice parameters are not allowed when 1088 -- No_Exception_Propagation applies, so set attributes 1089 -- accordingly. 1090 1091 Set_Local_Raise_Statements (Handler, No_Elist); 1092 Set_Local_Raise_Not_OK (Handler); 1093 1094 Analyze_List 1095 (Statements (Handler), Suppress => All_Checks); 1096 end; 1097 end if; 1098 1099 -- For the normal case, we have to worry about the state of 1100 -- abort deferral. Generally, we defer abort during runtime 1101 -- handling of exceptions. When control is passed to the 1102 -- handler, then in the normal case we undefer aborts. In 1103 -- any case this entire handling is relevant only if aborts 1104 -- are allowed. 1105 1106 if Abort_Allowed 1107 and then not ZCX_Exceptions 1108 then 1109 -- There are some special cases in which we do not do the 1110 -- undefer. In particular a finalization (AT END) handler 1111 -- wants to operate with aborts still deferred. 1112 1113 -- We also suppress the call if this is the special handler 1114 -- for Abort_Signal, since if we are aborting, we want to 1115 -- keep aborts deferred (one abort is enough). 1116 1117 -- If abort really needs to be deferred the expander must 1118 -- add this call explicitly, see 1119 -- Expand_N_Asynchronous_Select. 1120 1121 Others_Choice := 1122 Nkind (First (Exception_Choices (Handler))) = 1123 N_Others_Choice; 1124 1125 if (Others_Choice 1126 or else Entity (First (Exception_Choices (Handler))) /= 1127 Stand.Abort_Signal) 1128 and then not 1129 (Others_Choice 1130 and then 1131 All_Others (First (Exception_Choices (Handler)))) 1132 then 1133 Prepend_Call_To_Handler (RE_Abort_Undefer); 1134 end if; 1135 end if; 1136 end if; 1137 end if; 1138 1139 Handler := Next_Handler; 1140 end loop Handler_Loop; 1141 1142 -- If all handlers got removed, then remove the list. Note we cannot 1143 -- reference HSS here, since expanding local handlers may have buried 1144 -- the handlers in an inner block. 1145 1146 if Is_Empty_List (Handlrs) then 1147 Set_Exception_Handlers (Parent (Handlrs), No_List); 1148 end if; 1149 end Expand_Exception_Handlers; 1150 1151 ------------------------------------ 1152 -- Expand_N_Exception_Declaration -- 1153 ------------------------------------ 1154 1155 -- Generates: 1156 -- exceptE : constant String := "A.B.EXCEP"; -- static data 1157 -- except : exception_data := 1158 -- (Handled_By_Other => False, 1159 -- Lang => 'A', 1160 -- Name_Length => exceptE'Length, 1161 -- Full_Name => exceptE'Address, 1162 -- HTable_Ptr => null, 1163 -- Foreign_Data => null, 1164 -- Raise_Hook => null); 1165 1166 -- (protecting test only needed if not at library level) 1167 1168 -- exceptF : Boolean := True -- static data 1169 -- if exceptF then 1170 -- exceptF := False; 1171 -- Register_Exception (except'Unchecked_Access); 1172 -- end if; 1173 1174 procedure Expand_N_Exception_Declaration (N : Node_Id) is 1175 Id : constant Entity_Id := Defining_Identifier (N); 1176 Loc : constant Source_Ptr := Sloc (N); 1177 Ex_Id : Entity_Id; 1178 Flag_Id : Entity_Id; 1179 L : List_Id; 1180 1181 procedure Force_Static_Allocation_Of_Referenced_Objects 1182 (Aggregate : Node_Id); 1183 -- A specialized solution to one particular case of an ugly problem 1184 -- 1185 -- The given aggregate includes an Unchecked_Conversion as one of the 1186 -- component values. The call to Analyze_And_Resolve below ends up 1187 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide 1188 -- to introduce a (constant) temporary and then obtain the component 1189 -- value by evaluating the temporary. 1190 -- 1191 -- In the case of an exception declared within a subprogram (or any 1192 -- other dynamic scope), this is a bad transformation. The exception 1193 -- object is marked as being Statically_Allocated but the temporary is 1194 -- not. If the initial value of a Statically_Allocated declaration 1195 -- references a dynamically allocated object, this prevents static 1196 -- initialization of the object. 1197 -- 1198 -- We cope with this here by marking the temporary Statically_Allocated. 1199 -- It might seem cleaner to generalize this utility and then use it to 1200 -- enforce a rule that the entities referenced in the declaration of any 1201 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) 1202 -- entity must also be either Library_Level or hoisted. It turns out 1203 -- that this would be incompatible with the current treatment of an 1204 -- object which is local to a subprogram, subject to an Export pragma, 1205 -- not subject to an address clause, and whose declaration contains 1206 -- references to other local (non-hoisted) objects (e.g., in the initial 1207 -- value expression). 1208 1209 --------------------------------------------------- 1210 -- Force_Static_Allocation_Of_Referenced_Objects -- 1211 --------------------------------------------------- 1212 1213 procedure Force_Static_Allocation_Of_Referenced_Objects 1214 (Aggregate : Node_Id) 1215 is 1216 function Fixup_Node (N : Node_Id) return Traverse_Result; 1217 -- If the given node references a dynamically allocated object, then 1218 -- correct the declaration of the object. 1219 1220 ---------------- 1221 -- Fixup_Node -- 1222 ---------------- 1223 1224 function Fixup_Node (N : Node_Id) return Traverse_Result is 1225 begin 1226 if Nkind (N) in N_Has_Entity 1227 and then Present (Entity (N)) 1228 and then not Is_Library_Level_Entity (Entity (N)) 1229 1230 -- Note: the following test is not needed but it seems cleaner 1231 -- to do this test (this would be more important if procedure 1232 -- Force_Static_Allocation_Of_Referenced_Objects recursively 1233 -- traversed the declaration of an entity after marking it as 1234 -- statically allocated). 1235 1236 and then not Is_Statically_Allocated (Entity (N)) 1237 then 1238 Set_Is_Statically_Allocated (Entity (N)); 1239 end if; 1240 1241 return OK; 1242 end Fixup_Node; 1243 1244 procedure Fixup_Tree is new Traverse_Proc (Fixup_Node); 1245 1246 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects 1247 1248 begin 1249 Fixup_Tree (Aggregate); 1250 end Force_Static_Allocation_Of_Referenced_Objects; 1251 1252 -- Start of processing for Expand_N_Exception_Declaration 1253 1254 begin 1255 -- Nothing to do when generating C code 1256 1257 if Generate_C_Code then 1258 return; 1259 end if; 1260 1261 -- Definition of the external name: nam : constant String := "A.B.NAME"; 1262 1263 Ex_Id := 1264 Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E')); 1265 1266 Insert_Action (N, 1267 Make_Object_Declaration (Loc, 1268 Defining_Identifier => Ex_Id, 1269 Constant_Present => True, 1270 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1271 Expression => 1272 Make_String_Literal (Loc, 1273 Strval => Fully_Qualified_Name_String (Id)))); 1274 1275 Set_Is_Statically_Allocated (Ex_Id); 1276 1277 -- Create the aggregate list for type Standard.Exception_Type: 1278 -- Handled_By_Other component: False 1279 1280 L := Empty_List; 1281 Append_To (L, New_Occurrence_Of (Standard_False, Loc)); 1282 1283 -- Lang component: 'A' 1284 1285 Append_To (L, 1286 Make_Character_Literal (Loc, 1287 Chars => Name_uA, 1288 Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); 1289 1290 -- Name_Length component: Nam'Length 1291 1292 Append_To (L, 1293 Make_Attribute_Reference (Loc, 1294 Prefix => New_Occurrence_Of (Ex_Id, Loc), 1295 Attribute_Name => Name_Length)); 1296 1297 -- Full_Name component: Standard.A_Char!(Nam'Address) 1298 1299 -- The unchecked conversion causes capacity issues for CodePeer in some 1300 -- cases and is never useful, so we set the Full_Name component to null 1301 -- instead for CodePeer. 1302 1303 if CodePeer_Mode then 1304 Append_To (L, Make_Null (Loc)); 1305 else 1306 Append_To (L, Unchecked_Convert_To (Standard_A_Char, 1307 Make_Attribute_Reference (Loc, 1308 Prefix => New_Occurrence_Of (Ex_Id, Loc), 1309 Attribute_Name => Name_Address))); 1310 end if; 1311 1312 -- HTable_Ptr component: null 1313 1314 Append_To (L, Make_Null (Loc)); 1315 1316 -- Foreign_Data component: null 1317 1318 Append_To (L, Make_Null (Loc)); 1319 1320 -- Raise_Hook component: null 1321 1322 Append_To (L, Make_Null (Loc)); 1323 1324 Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); 1325 Analyze_And_Resolve (Expression (N), Etype (Id)); 1326 1327 Force_Static_Allocation_Of_Referenced_Objects (Expression (N)); 1328 1329 -- Register_Exception (except'Unchecked_Access); 1330 1331 if not No_Exception_Handlers_Set 1332 and then not Restriction_Active (No_Exception_Registration) 1333 then 1334 L := New_List ( 1335 Make_Procedure_Call_Statement (Loc, 1336 Name => 1337 New_Occurrence_Of (RTE (RE_Register_Exception), Loc), 1338 Parameter_Associations => New_List ( 1339 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), 1340 Make_Attribute_Reference (Loc, 1341 Prefix => New_Occurrence_Of (Id, Loc), 1342 Attribute_Name => Name_Unrestricted_Access))))); 1343 1344 Set_Register_Exception_Call (Id, First (L)); 1345 1346 if not Is_Library_Level_Entity (Id) then 1347 Flag_Id := 1348 Make_Defining_Identifier (Loc, 1349 Chars => New_External_Name (Chars (Id), 'F')); 1350 1351 Insert_Action (N, 1352 Make_Object_Declaration (Loc, 1353 Defining_Identifier => Flag_Id, 1354 Object_Definition => 1355 New_Occurrence_Of (Standard_Boolean, Loc), 1356 Expression => 1357 New_Occurrence_Of (Standard_True, Loc))); 1358 1359 Set_Is_Statically_Allocated (Flag_Id); 1360 1361 Append_To (L, 1362 Make_Assignment_Statement (Loc, 1363 Name => New_Occurrence_Of (Flag_Id, Loc), 1364 Expression => New_Occurrence_Of (Standard_False, Loc))); 1365 1366 Insert_After_And_Analyze (N, 1367 Make_Implicit_If_Statement (N, 1368 Condition => New_Occurrence_Of (Flag_Id, Loc), 1369 Then_Statements => L)); 1370 1371 else 1372 Insert_List_After_And_Analyze (N, L); 1373 end if; 1374 end if; 1375 end Expand_N_Exception_Declaration; 1376 1377 --------------------------------------------- 1378 -- Expand_N_Handled_Sequence_Of_Statements -- 1379 --------------------------------------------- 1380 1381 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is 1382 begin 1383 -- Expand exception handlers 1384 1385 if Present (Exception_Handlers (N)) 1386 and then not Restriction_Active (No_Exception_Handlers) 1387 then 1388 Expand_Exception_Handlers (N); 1389 end if; 1390 1391 -- If local exceptions are being expanded, the previous call will 1392 -- have rewritten the construct as a block and reanalyzed it. No 1393 -- further expansion is needed. 1394 1395 if Analyzed (N) then 1396 return; 1397 end if; 1398 1399 -- Add clean up actions if required 1400 1401 if not Nkind_In (Parent (N), N_Package_Body, 1402 N_Accept_Statement, 1403 N_Extended_Return_Statement) 1404 and then not Delay_Cleanups (Current_Scope) 1405 1406 -- No cleanup action needed in thunks associated with interfaces 1407 -- because they only displace the pointer to the object. 1408 1409 and then not Is_Thunk (Current_Scope) 1410 then 1411 Expand_Cleanup_Actions (Parent (N)); 1412 else 1413 Set_First_Real_Statement (N, First (Statements (N))); 1414 end if; 1415 end Expand_N_Handled_Sequence_Of_Statements; 1416 1417 ------------------------------------- 1418 -- Expand_N_Raise_Constraint_Error -- 1419 ------------------------------------- 1420 1421 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is 1422 begin 1423 -- We adjust the condition to deal with the C/Fortran boolean case. This 1424 -- may well not be necessary, as all such conditions are generated by 1425 -- the expander and probably are all standard boolean, but who knows 1426 -- what strange optimization in future may require this adjustment. 1427 1428 Adjust_Condition (Condition (N)); 1429 1430 -- Now deal with possible local raise handling 1431 1432 Possible_Local_Raise (N, Standard_Constraint_Error); 1433 end Expand_N_Raise_Constraint_Error; 1434 1435 ------------------------------- 1436 -- Expand_N_Raise_Expression -- 1437 ------------------------------- 1438 1439 procedure Expand_N_Raise_Expression (N : Node_Id) is 1440 Loc : constant Source_Ptr := Sloc (N); 1441 Typ : constant Entity_Id := Etype (N); 1442 RCE : Node_Id; 1443 1444 begin 1445 Possible_Local_Raise (N, Entity (Name (N))); 1446 1447 -- Later we must teach the back end/gigi how to deal with this, but 1448 -- for now we will assume the type is Standard_Boolean and transform 1449 -- the node to: 1450 1451 -- do 1452 -- raise X [with string] 1453 -- in 1454 -- raise Constraint_Error; 1455 1456 -- unless the flag Convert_To_Return_False is set, in which case 1457 -- the transformation is to: 1458 1459 -- do 1460 -- return False; 1461 -- in 1462 -- raise Constraint_Error; 1463 1464 -- The raise constraint error can never be executed. It is just a dummy 1465 -- node that can be labeled with an arbitrary type. 1466 1467 RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); 1468 Set_Etype (RCE, Typ); 1469 1470 if Convert_To_Return_False (N) then 1471 Rewrite (N, 1472 Make_Expression_With_Actions (Loc, 1473 Actions => New_List ( 1474 Make_Simple_Return_Statement (Loc, 1475 Expression => New_Occurrence_Of (Standard_False, Loc))), 1476 Expression => RCE)); 1477 1478 else 1479 Rewrite (N, 1480 Make_Expression_With_Actions (Loc, 1481 Actions => New_List ( 1482 Make_Raise_Statement (Loc, 1483 Name => Name (N), 1484 Expression => Expression (N))), 1485 Expression => RCE)); 1486 end if; 1487 1488 Analyze_And_Resolve (N, Typ); 1489 end Expand_N_Raise_Expression; 1490 1491 ---------------------------------- 1492 -- Expand_N_Raise_Program_Error -- 1493 ---------------------------------- 1494 1495 procedure Expand_N_Raise_Program_Error (N : Node_Id) is 1496 begin 1497 -- We adjust the condition to deal with the C/Fortran boolean case. This 1498 -- may well not be necessary, as all such conditions are generated by 1499 -- the expander and probably are all standard boolean, but who knows 1500 -- what strange optimization in future may require this adjustment. 1501 1502 Adjust_Condition (Condition (N)); 1503 1504 -- Now deal with possible local raise handling 1505 1506 Possible_Local_Raise (N, Standard_Program_Error); 1507 end Expand_N_Raise_Program_Error; 1508 1509 ------------------------------ 1510 -- Expand_N_Raise_Statement -- 1511 ------------------------------ 1512 1513 procedure Expand_N_Raise_Statement (N : Node_Id) is 1514 Loc : constant Source_Ptr := Sloc (N); 1515 Ehand : Node_Id; 1516 E : Entity_Id; 1517 Str : String_Id; 1518 H : Node_Id; 1519 Src : Boolean; 1520 1521 begin 1522 -- Processing for locally handled exception (exclude reraise case) 1523 1524 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then 1525 if Debug_Flag_Dot_G 1526 or else Restriction_Active (No_Exception_Propagation) 1527 then 1528 -- If we have a local handler, then note that this is potentially 1529 -- able to be transformed into a goto statement. 1530 1531 H := Find_Local_Handler (Entity (Name (N)), N); 1532 1533 if Present (H) then 1534 if Local_Raise_Statements (H) = No_Elist then 1535 Set_Local_Raise_Statements (H, New_Elmt_List); 1536 end if; 1537 1538 -- Append the new entry if it is not there already. Sometimes 1539 -- we have situations where due to reexpansion, the same node 1540 -- is analyzed twice and would otherwise be added twice. 1541 1542 Append_Unique_Elmt (N, Local_Raise_Statements (H)); 1543 Set_Has_Local_Raise (H); 1544 1545 -- If no local handler, then generate no propagation warning 1546 1547 else 1548 Warn_If_No_Propagation (N); 1549 end if; 1550 1551 end if; 1552 end if; 1553 1554 -- If a string expression is present, then the raise statement is 1555 -- converted to a call: 1556 -- Raise_Exception (exception-name'Identity, string); 1557 -- and there is nothing else to do. 1558 1559 if Present (Expression (N)) then 1560 1561 -- Adjust message to deal with Prefix_Exception_Messages. We only 1562 -- add the prefix to string literals, if the message is being 1563 -- constructed, we assume it already deals with uniqueness. 1564 1565 if Prefix_Exception_Messages 1566 and then Nkind (Expression (N)) = N_String_Literal 1567 then 1568 Name_Len := 0; 1569 Add_Source_Info (Loc, Name_Enclosing_Entity); 1570 Add_Str_To_Name_Buffer (": "); 1571 Add_String_To_Name_Buffer (Strval (Expression (N))); 1572 Rewrite (Expression (N), 1573 Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len))); 1574 Analyze_And_Resolve (Expression (N), Standard_String); 1575 end if; 1576 1577 -- Avoid passing exception-name'identity in runtimes in which this 1578 -- argument is not used. This avoids generating undefined references 1579 -- to these exceptions when compiling with no optimization 1580 1581 if Configurable_Run_Time_On_Target 1582 and then (Restriction_Active (No_Exception_Handlers) 1583 or else 1584 Restriction_Active (No_Exception_Propagation)) 1585 then 1586 Rewrite (N, 1587 Make_Procedure_Call_Statement (Loc, 1588 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1589 Parameter_Associations => New_List ( 1590 New_Occurrence_Of (RTE (RE_Null_Id), Loc), 1591 Expression (N)))); 1592 else 1593 Rewrite (N, 1594 Make_Procedure_Call_Statement (Loc, 1595 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1596 Parameter_Associations => New_List ( 1597 Make_Attribute_Reference (Loc, 1598 Prefix => Name (N), 1599 Attribute_Name => Name_Identity), 1600 Expression (N)))); 1601 end if; 1602 1603 Analyze (N); 1604 return; 1605 end if; 1606 1607 -- Remaining processing is for the case where no string expression is 1608 -- present. 1609 1610 -- Don't expand a raise statement that does not come from source if we 1611 -- have already had configurable run-time violations, since most likely 1612 -- it will be junk cascaded nonsense. 1613 1614 if Configurable_Run_Time_Violations > 0 1615 and then not Comes_From_Source (N) 1616 then 1617 return; 1618 end if; 1619 1620 -- Convert explicit raise of Program_Error, Constraint_Error, and 1621 -- Storage_Error into the corresponding raise (in High_Integrity_Mode 1622 -- all other raises will get normal expansion and be disallowed, 1623 -- but this is also faster in all modes). Propagate Comes_From_Source 1624 -- flag to the new node. 1625 1626 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then 1627 Src := Comes_From_Source (N); 1628 1629 if Entity (Name (N)) = Standard_Constraint_Error then 1630 Rewrite (N, 1631 Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise)); 1632 Set_Comes_From_Source (N, Src); 1633 Analyze (N); 1634 return; 1635 1636 elsif Entity (Name (N)) = Standard_Program_Error then 1637 Rewrite (N, 1638 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); 1639 Set_Comes_From_Source (N, Src); 1640 Analyze (N); 1641 return; 1642 1643 elsif Entity (Name (N)) = Standard_Storage_Error then 1644 Rewrite (N, 1645 Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise)); 1646 Set_Comes_From_Source (N, Src); 1647 Analyze (N); 1648 return; 1649 end if; 1650 end if; 1651 1652 -- Case of name present, in this case we expand raise name to 1653 1654 -- Raise_Exception (name'Identity, location_string); 1655 1656 -- where location_string identifies the file/line of the raise 1657 1658 if Present (Name (N)) then 1659 declare 1660 Id : Entity_Id := Entity (Name (N)); 1661 1662 begin 1663 Name_Len := 0; 1664 Build_Location_String (Loc); 1665 1666 -- If the exception is a renaming, use the exception that it 1667 -- renames (which might be a predefined exception, e.g.). 1668 1669 if Present (Renamed_Object (Id)) then 1670 Id := Renamed_Object (Id); 1671 end if; 1672 1673 -- Build a C-compatible string in case of no exception handlers, 1674 -- since this is what the last chance handler is expecting. 1675 1676 if No_Exception_Handlers_Set then 1677 1678 -- Generate an empty message if configuration pragma 1679 -- Suppress_Exception_Locations is set for this unit. 1680 1681 if Opt.Exception_Locations_Suppressed then 1682 Name_Len := 1; 1683 else 1684 Name_Len := Name_Len + 1; 1685 end if; 1686 1687 Name_Buffer (Name_Len) := ASCII.NUL; 1688 end if; 1689 1690 if Opt.Exception_Locations_Suppressed then 1691 Name_Len := 0; 1692 end if; 1693 1694 Str := String_From_Name_Buffer; 1695 1696 -- Convert raise to call to the Raise_Exception routine 1697 1698 Rewrite (N, 1699 Make_Procedure_Call_Statement (Loc, 1700 Name => 1701 New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), 1702 Parameter_Associations => New_List ( 1703 Make_Attribute_Reference (Loc, 1704 Prefix => Name (N), 1705 Attribute_Name => Name_Identity), 1706 Make_String_Literal (Loc, Strval => Str)))); 1707 end; 1708 1709 -- Case of no name present (reraise). We rewrite the raise to: 1710 1711 -- Reraise_Occurrence_Always (EO); 1712 1713 -- where EO is the current exception occurrence. If the current handler 1714 -- does not have a choice parameter specification, then we provide one. 1715 1716 else 1717 -- Bypass expansion to a run-time call when back-end exception 1718 -- handling is active, unless the target is CodePeer or GNATprove. 1719 -- In CodePeer, raising an exception is treated as an error, while in 1720 -- GNATprove all code with exceptions falls outside the subset of 1721 -- code which can be formally analyzed. 1722 1723 if not CodePeer_Mode 1724 and then Back_End_Exceptions 1725 then 1726 return; 1727 end if; 1728 1729 -- Find innermost enclosing exception handler (there must be one, 1730 -- since the semantics has already verified that this raise statement 1731 -- is valid, and a raise with no arguments is only permitted in the 1732 -- context of an exception handler. 1733 1734 Ehand := Parent (N); 1735 while Nkind (Ehand) /= N_Exception_Handler loop 1736 Ehand := Parent (Ehand); 1737 end loop; 1738 1739 -- Make exception choice parameter if none present. Note that we do 1740 -- not need to put the entity on the entity chain, since no one will 1741 -- be referencing this entity by normal visibility methods. 1742 1743 if No (Choice_Parameter (Ehand)) then 1744 E := Make_Temporary (Loc, 'E'); 1745 Set_Choice_Parameter (Ehand, E); 1746 Set_Ekind (E, E_Variable); 1747 Set_Etype (E, RTE (RE_Exception_Occurrence)); 1748 Set_Scope (E, Current_Scope); 1749 end if; 1750 1751 -- Now rewrite the raise as a call to Reraise. A special case arises 1752 -- if this raise statement occurs in the context of a handler for 1753 -- all others (i.e. an at end handler). in this case we avoid 1754 -- the call to defer abort, cleanup routines are expected to be 1755 -- called in this case with aborts deferred. 1756 1757 declare 1758 Ech : constant Node_Id := First (Exception_Choices (Ehand)); 1759 Ent : Entity_Id; 1760 1761 begin 1762 if Nkind (Ech) = N_Others_Choice 1763 and then All_Others (Ech) 1764 then 1765 Ent := RTE (RE_Reraise_Occurrence_No_Defer); 1766 else 1767 Ent := RTE (RE_Reraise_Occurrence_Always); 1768 end if; 1769 1770 Rewrite (N, 1771 Make_Procedure_Call_Statement (Loc, 1772 Name => New_Occurrence_Of (Ent, Loc), 1773 Parameter_Associations => New_List ( 1774 New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); 1775 end; 1776 end if; 1777 1778 Analyze (N); 1779 end Expand_N_Raise_Statement; 1780 1781 ---------------------------------- 1782 -- Expand_N_Raise_Storage_Error -- 1783 ---------------------------------- 1784 1785 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is 1786 begin 1787 -- We adjust the condition to deal with the C/Fortran boolean case. This 1788 -- may well not be necessary, as all such conditions are generated by 1789 -- the expander and probably are all standard boolean, but who knows 1790 -- what strange optimization in future may require this adjustment. 1791 1792 Adjust_Condition (Condition (N)); 1793 1794 -- Now deal with possible local raise handling 1795 1796 Possible_Local_Raise (N, Standard_Storage_Error); 1797 end Expand_N_Raise_Storage_Error; 1798 1799 -------------------------- 1800 -- Possible_Local_Raise -- 1801 -------------------------- 1802 1803 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is 1804 begin 1805 -- Nothing to do if local raise optimization not active 1806 1807 if not Debug_Flag_Dot_G 1808 and then not Restriction_Active (No_Exception_Propagation) 1809 then 1810 return; 1811 end if; 1812 1813 -- Nothing to do if original node was an explicit raise, because in 1814 -- that case, we already generated the required warning for the raise. 1815 1816 if Nkind (Original_Node (N)) = N_Raise_Statement then 1817 return; 1818 end if; 1819 1820 -- Otherwise see if we have a local handler for the exception 1821 1822 declare 1823 H : constant Node_Id := Find_Local_Handler (E, N); 1824 1825 begin 1826 -- If so, mark that it has a local raise 1827 1828 if Present (H) then 1829 Set_Has_Local_Raise (H, True); 1830 1831 -- Otherwise, if the No_Exception_Propagation restriction is active 1832 -- and the warning is enabled, generate the appropriate warnings. 1833 1834 elsif Warn_On_Non_Local_Exception 1835 and then Restriction_Active (No_Exception_Propagation) 1836 then 1837 Warn_No_Exception_Propagation_Active (N); 1838 1839 if Configurable_Run_Time_Mode then 1840 Error_Msg_NE 1841 ("\?X?& may call Last_Chance_Handler", N, E); 1842 else 1843 Error_Msg_NE 1844 ("\?X?& may result in unhandled exception", N, E); 1845 end if; 1846 end if; 1847 end; 1848 end Possible_Local_Raise; 1849 1850 ------------------------ 1851 -- Find_Local_Handler -- 1852 ------------------------ 1853 1854 function Find_Local_Handler 1855 (Ename : Entity_Id; 1856 Nod : Node_Id) return Node_Id 1857 is 1858 N : Node_Id; 1859 P : Node_Id; 1860 H : Node_Id; 1861 C : Node_Id; 1862 1863 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 1864 -- This is used to test for wrapped actions below 1865 1866 ERaise : Entity_Id; 1867 EHandle : Entity_Id; 1868 -- The entity Id's for the exception we are raising and handling, using 1869 -- the renamed exception if a Renamed_Entity is present. 1870 1871 begin 1872 -- Never any local handler if all handlers removed 1873 1874 if Debug_Flag_Dot_X then 1875 return Empty; 1876 end if; 1877 1878 -- Get the exception we are raising, allowing for renaming 1879 1880 ERaise := Get_Renamed_Entity (Ename); 1881 1882 -- We need to check if the node we are looking at is contained in 1883 -- 1884 1885 -- Loop to search up the tree 1886 1887 N := Nod; 1888 loop 1889 P := Parent (N); 1890 1891 -- If we get to the top of the tree, or to a subprogram, task, entry, 1892 -- protected body, or accept statement without having found a 1893 -- matching handler, then there is no local handler. 1894 1895 if No (P) 1896 or else Nkind (P) = N_Subprogram_Body 1897 or else Nkind (P) = N_Task_Body 1898 or else Nkind (P) = N_Protected_Body 1899 or else Nkind (P) = N_Entry_Body 1900 or else Nkind (P) = N_Accept_Statement 1901 then 1902 return Empty; 1903 1904 -- Test for handled sequence of statements with at least one 1905 -- exception handler which might be the one we are looking for. 1906 1907 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 1908 and then Present (Exception_Handlers (P)) 1909 then 1910 -- Before we proceed we need to check if the node N is covered 1911 -- by the statement part of P rather than one of its exception 1912 -- handlers (an exception handler obviously does not cover its 1913 -- own statements). 1914 1915 -- This test is more delicate than might be thought. It is not 1916 -- just a matter of checking the Statements (P), because the node 1917 -- might be waiting to be wrapped in a transient scope, in which 1918 -- case it will end up in the block statements, even though it 1919 -- is not there now. 1920 1921 if Is_List_Member (N) then 1922 declare 1923 LCN : constant List_Id := List_Containing (N); 1924 1925 begin 1926 if LCN = Statements (P) 1927 or else 1928 LCN = SSE.Actions_To_Be_Wrapped (Before) 1929 or else 1930 LCN = SSE.Actions_To_Be_Wrapped (After) 1931 or else 1932 LCN = SSE.Actions_To_Be_Wrapped (Cleanup) 1933 then 1934 -- Loop through exception handlers 1935 1936 H := First (Exception_Handlers (P)); 1937 while Present (H) loop 1938 1939 -- Guard against other constructs appearing in the 1940 -- list of exception handlers. 1941 1942 if Nkind (H) = N_Exception_Handler then 1943 1944 -- Loop through choices in one handler 1945 1946 C := First (Exception_Choices (H)); 1947 while Present (C) loop 1948 1949 -- Deal with others case 1950 1951 if Nkind (C) = N_Others_Choice then 1952 1953 -- Matching others handler, but we need 1954 -- to ensure there is no choice parameter. 1955 -- If there is, then we don't have a local 1956 -- handler after all (since we do not allow 1957 -- choice parameters for local handlers). 1958 1959 if No (Choice_Parameter (H)) then 1960 return H; 1961 else 1962 return Empty; 1963 end if; 1964 1965 -- If not others must be entity name 1966 1967 elsif Nkind (C) /= N_Others_Choice then 1968 pragma Assert (Is_Entity_Name (C)); 1969 pragma Assert (Present (Entity (C))); 1970 1971 -- Get exception being handled, dealing with 1972 -- renaming. 1973 1974 EHandle := Get_Renamed_Entity (Entity (C)); 1975 1976 -- If match, then check choice parameter 1977 1978 if ERaise = EHandle then 1979 if No (Choice_Parameter (H)) then 1980 return H; 1981 else 1982 return Empty; 1983 end if; 1984 end if; 1985 end if; 1986 1987 Next (C); 1988 end loop; 1989 end if; 1990 1991 Next (H); 1992 end loop; 1993 end if; 1994 end; 1995 end if; 1996 end if; 1997 1998 N := P; 1999 end loop; 2000 end Find_Local_Handler; 2001 2002 --------------------------------- 2003 -- Get_Local_Raise_Call_Entity -- 2004 --------------------------------- 2005 2006 -- Note: this is primarily provided for use by the back end in generating 2007 -- calls to Local_Raise. But it would be too late in the back end to call 2008 -- RTE if this actually caused a load/analyze of the unit. So what we do 2009 -- is to ensure there is a dummy call to this function during front end 2010 -- processing so that the unit gets loaded then, and not later. 2011 2012 Local_Raise_Call_Entity : Entity_Id; 2013 Local_Raise_Call_Entity_Set : Boolean := False; 2014 2015 function Get_Local_Raise_Call_Entity return Entity_Id is 2016 begin 2017 if not Local_Raise_Call_Entity_Set then 2018 Local_Raise_Call_Entity_Set := True; 2019 2020 if RTE_Available (RE_Local_Raise) then 2021 Local_Raise_Call_Entity := RTE (RE_Local_Raise); 2022 else 2023 Local_Raise_Call_Entity := Empty; 2024 end if; 2025 end if; 2026 2027 return Local_Raise_Call_Entity; 2028 end Get_Local_Raise_Call_Entity; 2029 2030 ----------------------------- 2031 -- Get_RT_Exception_Entity -- 2032 ----------------------------- 2033 2034 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is 2035 begin 2036 case Rkind (R) is 2037 when CE_Reason => return Standard_Constraint_Error; 2038 when PE_Reason => return Standard_Program_Error; 2039 when SE_Reason => return Standard_Storage_Error; 2040 end case; 2041 end Get_RT_Exception_Entity; 2042 2043 --------------------------- 2044 -- Get_RT_Exception_Name -- 2045 --------------------------- 2046 2047 procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is 2048 begin 2049 case Code is 2050 when CE_Access_Check_Failed => 2051 Add_Str_To_Name_Buffer ("CE_Access_Check"); 2052 when CE_Access_Parameter_Is_Null => 2053 Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter"); 2054 when CE_Discriminant_Check_Failed => 2055 Add_Str_To_Name_Buffer ("CE_Discriminant_Check"); 2056 when CE_Divide_By_Zero => 2057 Add_Str_To_Name_Buffer ("CE_Divide_By_Zero"); 2058 when CE_Explicit_Raise => 2059 Add_Str_To_Name_Buffer ("CE_Explicit_Raise"); 2060 when CE_Index_Check_Failed => 2061 Add_Str_To_Name_Buffer ("CE_Index_Check"); 2062 when CE_Invalid_Data => 2063 Add_Str_To_Name_Buffer ("CE_Invalid_Data"); 2064 when CE_Length_Check_Failed => 2065 Add_Str_To_Name_Buffer ("CE_Length_Check"); 2066 when CE_Null_Exception_Id => 2067 Add_Str_To_Name_Buffer ("CE_Null_Exception_Id"); 2068 when CE_Null_Not_Allowed => 2069 Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed"); 2070 when CE_Overflow_Check_Failed => 2071 Add_Str_To_Name_Buffer ("CE_Overflow_Check"); 2072 when CE_Partition_Check_Failed => 2073 Add_Str_To_Name_Buffer ("CE_Partition_Check"); 2074 when CE_Range_Check_Failed => 2075 Add_Str_To_Name_Buffer ("CE_Range_Check"); 2076 when CE_Tag_Check_Failed => 2077 Add_Str_To_Name_Buffer ("CE_Tag_Check"); 2078 2079 when PE_Access_Before_Elaboration => 2080 Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration"); 2081 when PE_Accessibility_Check_Failed => 2082 Add_Str_To_Name_Buffer ("PE_Accessibility_Check"); 2083 when PE_Address_Of_Intrinsic => 2084 Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic"); 2085 when PE_Aliased_Parameters => 2086 Add_Str_To_Name_Buffer ("PE_Aliased_Parameters"); 2087 when PE_All_Guards_Closed => 2088 Add_Str_To_Name_Buffer ("PE_All_Guards_Closed"); 2089 when PE_Bad_Predicated_Generic_Type => 2090 Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type"); 2091 when PE_Current_Task_In_Entry_Body => 2092 Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body"); 2093 when PE_Duplicated_Entry_Address => 2094 Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address"); 2095 when PE_Explicit_Raise => 2096 Add_Str_To_Name_Buffer ("PE_Explicit_Raise"); 2097 when PE_Finalize_Raised_Exception => 2098 Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception"); 2099 when PE_Implicit_Return => 2100 Add_Str_To_Name_Buffer ("PE_Implicit_Return"); 2101 when PE_Misaligned_Address_Value => 2102 Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value"); 2103 when PE_Missing_Return => 2104 Add_Str_To_Name_Buffer ("PE_Missing_Return"); 2105 when PE_Non_Transportable_Actual => 2106 Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); 2107 when PE_Overlaid_Controlled_Object => 2108 Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object"); 2109 when PE_Potentially_Blocking_Operation => 2110 Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation"); 2111 when PE_Stream_Operation_Not_Allowed => 2112 Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed"); 2113 when PE_Stubbed_Subprogram_Called => 2114 Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called"); 2115 when PE_Unchecked_Union_Restriction => 2116 Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction"); 2117 2118 when SE_Empty_Storage_Pool => 2119 Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool"); 2120 when SE_Explicit_Raise => 2121 Add_Str_To_Name_Buffer ("SE_Explicit_Raise"); 2122 when SE_Infinite_Recursion => 2123 Add_Str_To_Name_Buffer ("SE_Infinite_Recursion"); 2124 when SE_Object_Too_Large => 2125 Add_Str_To_Name_Buffer ("SE_Object_Too_Large"); 2126 end case; 2127 end Get_RT_Exception_Name; 2128 2129 ---------------------------- 2130 -- Warn_If_No_Propagation -- 2131 ---------------------------- 2132 2133 procedure Warn_If_No_Propagation (N : Node_Id) is 2134 begin 2135 if Restriction_Check_Required (No_Exception_Propagation) 2136 and then Warn_On_Non_Local_Exception 2137 then 2138 Warn_No_Exception_Propagation_Active (N); 2139 2140 if Configurable_Run_Time_Mode then 2141 Error_Msg_N 2142 ("\?X?Last_Chance_Handler will be called on exception", N); 2143 else 2144 Error_Msg_N 2145 ("\?X?execution may raise unhandled exception", N); 2146 end if; 2147 end if; 2148 end Warn_If_No_Propagation; 2149 2150 ------------------------------------------ 2151 -- Warn_No_Exception_Propagation_Active -- 2152 ------------------------------------------ 2153 2154 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is 2155 begin 2156 Error_Msg_N 2157 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N); 2158 end Warn_No_Exception_Propagation_Active; 2159 2160end Exp_Ch11; 2161