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