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