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