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