1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Util; use Exp_Util;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
39 with Rtsfind; use Rtsfind;
40 with Restrict; use Restrict;
41 with Rident; use Rident;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Res; use Sem_Res;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Sinput; use Sinput;
48 with Snames; use Snames;
49 with Stand; use Stand;
50 with Stringt; use Stringt;
51 with Targparm; use Targparm;
52 with Tbuild; use Tbuild;
53 with Uintp; use Uintp;
55 package body Exp_Ch11 is
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 procedure Warn_No_Exception_Propagation_Active (N : Node_Id);
62 -- Generates warning that pragma Restrictions (No_Exception_Propagation)
63 -- is in effect. Caller then generates appropriate continuation message.
64 -- N is the node on which the warning is placed.
66 procedure Warn_If_No_Propagation (N : Node_Id);
67 -- Called for an exception raise that is not a local raise (and thus can
68 -- not be optimized to a goto. Issues warning if No_Exception_Propagation
69 -- restriction is set. N is the node for the raise or equivalent call.
71 ---------------------------
72 -- Expand_At_End_Handler --
73 ---------------------------
75 -- For a handled statement sequence that has a cleanup (At_End_Proc
76 -- field set), an exception handler of the following form is required:
83 -- Note: this exception handler is treated rather specially by
84 -- subsequent expansion in two respects:
86 -- The normal call to Undefer_Abort is omitted
87 -- The raise call does not do Defer_Abort
89 -- This is because the current tasking code seems to assume that
90 -- the call to the cleanup routine that is made from an exception
91 -- handler for the abort signal is called with aborts deferred.
93 -- This expansion is only done if we have front end exception handling.
94 -- If we have back end exception handling, then the AT END handler is
95 -- left alone, and cleanups (including the exceptional case) are handled
98 -- In the front end case, the exception handler described above handles
99 -- the exceptional case. The AT END handler is left in the generated tree
100 -- and the code generator (e.g. gigi) must still handle proper generation
101 -- of cleanup calls for the non-exceptional case.
103 procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
104 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
105 Loc : constant Source_Ptr := Sloc (Clean);
110 pragma Assert (Present (Clean));
111 pragma Assert (No (Exception_Handlers (HSS)));
113 -- Don't expand if back end exception handling active
115 if Exception_Mechanism = Back_End_Exceptions then
119 -- Don't expand an At End handler if we have already had configurable
120 -- run-time violations, since likely this will just be a matter of
121 -- generating useless cascaded messages
123 if Configurable_Run_Time_Violations > 0 then
127 -- Don't expand an At End handler if we are not allowing exceptions
128 -- or if exceptions are transformed into local gotos, and never
129 -- propagated (No_Exception_Propagation).
131 if No_Exception_Handlers_Set then
135 if Present (Block) then
140 Make_Others_Choice (Loc);
141 Set_All_Others (Ohandle);
144 Make_Procedure_Call_Statement (Loc,
145 Name => New_Occurrence_Of (Clean, Loc)));
147 -- Avoid generation of raise stmt if compiling with no exceptions
150 if not Restriction_Active (No_Exception_Propagation) then
152 Make_Raise_Statement (Loc));
155 Set_Exception_Handlers (HSS, New_List (
156 Make_Implicit_Exception_Handler (Loc,
157 Exception_Choices => New_List (Ohandle),
158 Statements => Stmnts)));
160 Analyze_List (Stmnts, Suppress => All_Checks);
161 Expand_Exception_Handlers (HSS);
163 if Present (Block) then
166 end Expand_At_End_Handler;
168 -------------------------------
169 -- Expand_Exception_Handlers --
170 -------------------------------
172 procedure Expand_Exception_Handlers (HSS : Node_Id) is
173 Handlrs : constant List_Id := Exception_Handlers (HSS);
174 Loc : constant Source_Ptr := Sloc (HSS);
176 Others_Choice : Boolean;
178 Next_Handler : Node_Id;
180 procedure Expand_Local_Exception_Handlers;
181 -- This procedure handles the expansion of exception handlers for the
182 -- optimization of local raise statements into goto statements.
184 procedure Prepend_Call_To_Handler
186 Args : List_Id := No_List);
187 -- Routine to prepend a call to the procedure referenced by Proc at
188 -- the start of the handler code for the current Handler.
190 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
191 -- Raise_S is a raise statement (possibly expanded, and possibly of the
192 -- form of a Raise_xxx_Error node with a condition. This procedure is
193 -- called to replace the raise action with the (already analyzed) goto
194 -- statement passed as Goto_L1. This procedure also takes care of the
195 -- requirement of inserting a Local_Raise call where possible.
197 -------------------------------------
198 -- Expand_Local_Exception_Handlers --
199 -------------------------------------
201 -- There are two cases for this transformation. First the case of
202 -- explicit raise statements. For this case, the transformation we do
203 -- looks like this. Right now we have for example (where L1, L2 are
208 -- raise_exception (excep1'identity); -- was raise excep1
210 -- raise_exception (excep2'identity); -- was raise excep2
219 -- This gets transformed into:
222 -- L1 : label; -- marked Exception_Junk
223 -- L2 : label; -- marked Exception_Junk
224 -- L3 : label; -- marked Exception_Junk
226 -- begin -- marked Exception_Junk
228 -- local_raise (excep1'address); -- was raise excep1
231 -- local_raise (excep2'address); -- was raise excep2
241 -- goto L3; -- skip handler if no raise, marked Exception_Junk
243 -- <<L1>> -- local excep target label, marked Exception_Junk
244 -- begin -- marked Exception_Junk
247 -- goto L3; -- marked Exception_Junk
249 -- <<L2>> -- marked Exception_Junk
250 -- begin -- marked Exception_Junk
253 -- goto L3; -- marked Exception_Junk
254 -- <<L3>> -- marked Exception_Junk
257 -- Note: the reason we wrap the original statement sequence in an
258 -- inner block is that there may be raise statements within the
259 -- sequence of statements in the handlers, and we must ensure that
260 -- these are properly handled, and in particular, such raise statements
261 -- must not reenter the same exception handlers.
263 -- If the restriction No_Exception_Propagation is in effect, then we
264 -- can omit the exception handlers.
267 -- L1 : label; -- marked Exception_Junk
268 -- L2 : label; -- marked Exception_Junk
269 -- L3 : label; -- marked Exception_Junk
271 -- begin -- marked Exception_Junk
273 -- local_raise (excep1'address); -- was raise excep1
276 -- local_raise (excep2'address); -- was raise excep2
281 -- goto L3; -- skip handler if no raise, marked Exception_Junk
283 -- <<L1>> -- local excep target label, marked Exception_Junk
284 -- begin -- marked Exception_Junk
287 -- goto L3; -- marked Exception_Junk
289 -- <<L2>> -- marked Exception_Junk
290 -- begin -- marked Exception_Junk
294 -- <<L3>> -- marked Exception_Junk
297 -- The second case is for exceptions generated by the back end in one
298 -- of three situations:
300 -- 1. Front end generates N_Raise_xxx_Error node
301 -- 2. Front end sets Do_xxx_Check flag in subexpression node
302 -- 3. Back end detects a situation where an exception is appropriate
304 -- In all these cases, the current processing in gigi is to generate a
305 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
306 -- exception message and the exception to be raised, Constraint_Error,
307 -- Program_Error, or Storage_Error.
309 -- We could handle some subcases of 1 using the same front end expansion
310 -- into gotos, but even for case 1, we can't handle all cases, since
311 -- generating gotos in the middle of expressions is not possible (it's
312 -- possible at the gigi/gcc level, but not at the level of the GNAT
315 -- In any case, it seems easier to have a scheme which handles all three
316 -- cases in a uniform manner. So here is how we proceed in this case.
318 -- This procedure detects all handlers for these three exceptions,
319 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
320 -- OTHERS handlers that cover one or more of these cases).
322 -- If the handler meets the requirements for being the target of a local
323 -- raise, then the front end does the expansion described previously,
324 -- creating a label to be used as a goto target to raise the exception.
325 -- However, no attempt is made in the front end to convert any related
326 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
327 -- left unchanged and passed to the back end.
329 -- Instead, the front end generates two nodes
331 -- N_Push_Constraint_Error_Label
332 -- N_Push_Program_Error_Label
333 -- N_Push_Storage_Error_Label
335 -- The Push node is generated at the start of the statements
336 -- covered by the handler, and has as a parameter the label to be
337 -- used as the raise target.
339 -- N_Pop_Constraint_Error_Label
340 -- N_Pop_Program_Error_Label
341 -- N_Pop_Storage_Error_Label
343 -- The Pop node is generated at the end of the covered statements
344 -- and undoes the effect of the preceding corresponding Push node.
346 -- In the case where the handler does NOT meet the requirements, the
347 -- front end will still generate the Push and Pop nodes, but the label
348 -- field in the Push node will be empty signifying that for this region
349 -- of code, no optimization is possible.
351 -- The back end must maintain three stacks, one for each exception case,
352 -- the Push node pushes an entry onto the corresponding stack, and Pop
353 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
354 -- corresponding top stack entry has an non-empty label, a goto is
355 -- generated. This goto should be preceded by a call to Local_Raise as
358 -- An example of this transformation is as follows, given:
361 -- A : Integer range 1 .. 10;
365 -- when Constraint_Error =>
369 -- gets transformed to:
372 -- A : Integer range 1 .. 10;
379 -- %push_constraint_error_label (L1)
380 -- R1b : constant long_long_integer := long_long_integer?(b) +
381 -- long_long_integer?(c);
382 -- [constraint_error when
383 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
384 -- "overflow check failed"]
385 -- a := integer?(R1b);
386 -- %pop_constraint_error_Label
390 -- when constraint_error =>
394 -- goto L2; -- skip handler when exception not raised
395 -- <<L1>> -- target label for local exception
400 -- Note: the generated labels and goto statements all have the flag
401 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
402 -- this generated exception stuff when checking for missing return
403 -- statements (see circuitry in Check_Statement_Sequence).
405 -- Note: All of the processing described above occurs only if
406 -- restriction No_Exception_Propagation applies or debug flag .g is
409 CE_Locally_Handled : Boolean := False;
410 SE_Locally_Handled : Boolean := False;
411 PE_Locally_Handled : Boolean := False;
412 -- These three flags indicate whether a handler for the corresponding
413 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
414 -- is present. If so the switch is set to True, the Exception_Label
415 -- field of the corresponding handler is set, and appropriate Push
416 -- and Pop nodes are inserted into the code.
418 Local_Expansion_Required : Boolean := False;
419 -- Set True if we have at least one handler requiring local raise
420 -- expansion as described above.
422 procedure Expand_Local_Exception_Handlers is
424 procedure Add_Exception_Label (H : Node_Id);
425 -- H is an exception handler. First check for an Exception_Label
426 -- already allocated for H. If none, allocate one, set the field in
427 -- the handler node, add the label declaration, and set the flag
428 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
429 -- the call has no effect and Exception_Label is left empty.
431 procedure Add_Label_Declaration (L : Entity_Id);
432 -- Add an implicit declaration of the given label to the declaration
433 -- list in the parent of the current sequence of handled statements.
436 Exc_Locally_Handled : in out Boolean;
437 -- Flag indicating whether a local handler for this exception
438 -- has already been generated.
440 with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
441 -- Function to create a Push_xxx_Label node
443 with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
444 -- Function to create a Pop_xxx_Label node
446 procedure Generate_Push_Pop (H : Node_Id);
447 -- Common code for Generate_Push_Pop_xxx below, used to generate an
448 -- exception label and Push/Pop nodes for Constraint_Error,
449 -- Program_Error, or Storage_Error.
451 -------------------------
452 -- Add_Exception_Label --
453 -------------------------
455 procedure Add_Exception_Label (H : Node_Id) is
457 if No (Exception_Label (H))
458 and then not Local_Raise_Not_OK (H)
459 and then not Special_Exception_Package_Used
461 Local_Expansion_Required := True;
464 L : constant Entity_Id :=
465 Make_Defining_Identifier (Sloc (H),
466 Chars => New_Internal_Name ('L'));
468 Set_Exception_Label (H, L);
469 Add_Label_Declaration (L);
472 end Add_Exception_Label;
474 ---------------------------
475 -- Add_Label_Declaration --
476 ---------------------------
478 procedure Add_Label_Declaration (L : Entity_Id) is
479 P : constant Node_Id := Parent (HSS);
481 Decl_L : constant Node_Id :=
482 Make_Implicit_Label_Declaration (Loc,
483 Defining_Identifier => L);
486 if Declarations (P) = No_List then
487 Set_Declarations (P, Empty_List);
490 Append (Decl_L, Declarations (P));
492 end Add_Label_Declaration;
494 -----------------------
495 -- Generate_Push_Pop --
496 -----------------------
498 procedure Generate_Push_Pop (H : Node_Id) is
500 if Exc_Locally_Handled then
503 Exc_Locally_Handled := True;
506 Add_Exception_Label (H);
509 F : constant Node_Id := First (Statements (HSS));
510 L : constant Node_Id := Last (Statements (HSS));
512 Push : constant Node_Id := Make_Push_Label (Sloc (F));
513 Pop : constant Node_Id := Make_Pop_Label (Sloc (L));
516 -- We make sure that a call to Get_Local_Raise_Call_Entity is
517 -- made during front end processing, so that when we need it
518 -- in the back end, it will already be available and loaded.
520 Discard_Node (Get_Local_Raise_Call_Entity);
522 -- Prepare and insert Push and Pop nodes
524 Set_Exception_Label (Push, Exception_Label (H));
525 Insert_Before (F, Push);
528 Insert_After (L, Pop);
531 end Generate_Push_Pop;
533 -- Local declarations
535 Loc : constant Source_Ptr := Sloc (HSS);
536 Stmts : List_Id := No_List;
540 procedure Generate_Push_Pop_For_Constraint_Error is
541 new Generate_Push_Pop
542 (Exc_Locally_Handled => CE_Locally_Handled,
543 Make_Push_Label => Make_Push_Constraint_Error_Label,
544 Make_Pop_Label => Make_Pop_Constraint_Error_Label);
545 -- If no Push/Pop has been generated for CE yet, then set the flag
546 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
547 -- not already done), and generate Push/Pop nodes for the exception
548 -- label at the start and end of the statements of HSS.
550 procedure Generate_Push_Pop_For_Program_Error is
551 new Generate_Push_Pop
552 (Exc_Locally_Handled => PE_Locally_Handled,
553 Make_Push_Label => Make_Push_Program_Error_Label,
554 Make_Pop_Label => Make_Pop_Program_Error_Label);
555 -- If no Push/Pop has been generated for PE yet, then set the flag
556 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
557 -- not already done), and generate Push/Pop nodes for the exception
558 -- label at the start and end of the statements of HSS.
560 procedure Generate_Push_Pop_For_Storage_Error is
561 new Generate_Push_Pop
562 (Exc_Locally_Handled => SE_Locally_Handled,
563 Make_Push_Label => Make_Push_Storage_Error_Label,
564 Make_Pop_Label => Make_Pop_Storage_Error_Label);
565 -- If no Push/Pop has been generated for SE yet, then set the flag
566 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
567 -- not already done), and generate Push/Pop nodes for the exception
568 -- label at the start and end of the statements of HSS.
570 -- Start of processing for Expand_Local_Exception_Handlers
573 -- No processing if all exception handlers will get removed
575 if Debug_Flag_Dot_X then
579 -- See for each handler if we have any local raises to expand
581 Handler := First_Non_Pragma (Handlrs);
582 while Present (Handler) loop
584 -- Note, we do not test Local_Raise_Not_OK here, because in the
585 -- case of Push/Pop generation we want to generate push with a
586 -- null label. The Add_Exception_Label routine has no effect if
587 -- Local_Raise_Not_OK is set, so this works as required.
589 if Present (Local_Raise_Statements (Handler)) then
590 Add_Exception_Label (Handler);
593 -- If we are doing local raise to goto optimization (restriction
594 -- No_Exception_Propagation set or debug flag .g set), then check
595 -- to see if handler handles CE, PE, SE and if so generate the
596 -- appropriate push/pop sequence for the back end.
599 or else Restriction_Active (No_Exception_Propagation))
600 and then Has_Local_Raise (Handler)
602 Choice := First (Exception_Choices (Handler));
603 while Present (Choice) loop
604 if Nkind (Choice) = N_Others_Choice
605 and then not All_Others (Choice)
607 Generate_Push_Pop_For_Constraint_Error (Handler);
608 Generate_Push_Pop_For_Program_Error (Handler);
609 Generate_Push_Pop_For_Storage_Error (Handler);
611 elsif Is_Entity_Name (Choice) then
612 Excep := Get_Renamed_Entity (Entity (Choice));
614 if Excep = Standard_Constraint_Error then
615 Generate_Push_Pop_For_Constraint_Error (Handler);
616 elsif Excep = Standard_Program_Error then
617 Generate_Push_Pop_For_Program_Error (Handler);
618 elsif Excep = Standard_Storage_Error then
619 Generate_Push_Pop_For_Storage_Error (Handler);
627 Next_Non_Pragma (Handler);
630 -- Nothing to do if no handlers requiring the goto transformation
632 if not (Local_Expansion_Required) then
636 -- Prepare to do the transformation
639 -- L3 is the label to exit the HSS
641 L3_Dent : constant Entity_Id :=
642 Make_Defining_Identifier (Loc,
643 Chars => New_Internal_Name ('L'));
645 Labl_L3 : constant Node_Id :=
647 Identifier => New_Occurrence_Of (L3_Dent, Loc));
653 Set_Exception_Junk (Labl_L3);
654 Add_Label_Declaration (L3_Dent);
656 -- Wrap existing statements and handlers in an inner block
659 Make_Block_Statement (Loc,
660 Handled_Statement_Sequence => Relocate_Node (HSS));
661 Set_Exception_Junk (Blk_Stm);
664 Make_Handled_Sequence_Of_Statements (Loc,
665 Statements => New_List (Blk_Stm)));
667 -- Set block statement as analyzed, we don't want to actually call
668 -- Analyze on this block, it would cause a recursion in exception
669 -- handler processing which would mess things up.
671 Set_Analyzed (Blk_Stm);
673 -- Now loop through the exception handlers to deal with those that
674 -- are targets of local raise statements.
676 Handler := First_Non_Pragma (Handlrs);
677 while Present (Handler) loop
678 if Present (Exception_Label (Handler)) then
680 -- This handler needs the goto expansion
683 Loc : constant Source_Ptr := Sloc (Handler);
685 -- L1 is the start label for this handler
687 L1_Dent : constant Entity_Id := Exception_Label (Handler);
689 Labl_L1 : constant Node_Id :=
692 New_Occurrence_Of (L1_Dent, Loc));
694 -- Jump to L1 to be used as replacement for the original
695 -- handler (used in the case where exception propagation
698 Name_L1 : constant Node_Id :=
699 New_Occurrence_Of (L1_Dent, Loc);
701 Goto_L1 : constant Node_Id :=
702 Make_Goto_Statement (Loc,
705 -- Jump to L3 to be used at the end of handler
707 Name_L3 : constant Node_Id :=
708 New_Occurrence_Of (L3_Dent, Loc);
710 Goto_L3 : constant Node_Id :=
711 Make_Goto_Statement (Loc,
714 H_Stmts : constant List_Id := Statements (Handler);
717 Set_Exception_Junk (Labl_L1);
718 Set_Exception_Junk (Goto_L3);
720 -- Note: we do NOT set Exception_Junk in Goto_L1, since
721 -- this is a real transfer of control that we want the
722 -- Sem_Ch6.Check_Returns procedure to recognize properly.
724 -- Replace handler by a goto L1. We can mark this as
725 -- analyzed since it is fully formed, and we don't
726 -- want it going through any further checks. We save
727 -- the last statement location in the goto L1 node for
728 -- the benefit of Sem_Ch6.Check_Returns.
730 Set_Statements (Handler, New_List (Goto_L1));
731 Set_Analyzed (Goto_L1);
732 Set_Etype (Name_L1, Standard_Void_Type);
734 -- Now replace all the raise statements by goto L1
736 if Present (Local_Raise_Statements (Handler)) then
737 Relmt := First_Elmt (Local_Raise_Statements (Handler));
738 while Present (Relmt) loop
740 Raise_S : constant Node_Id := Node (Relmt);
742 Name_L1 : constant Node_Id :=
743 New_Occurrence_Of (L1_Dent, Loc);
745 Goto_L1 : constant Node_Id :=
746 Make_Goto_Statement (Loc,
750 -- Replace raise by goto L1
752 Set_Analyzed (Goto_L1);
753 Set_Etype (Name_L1, Standard_Void_Type);
754 Replace_Raise_By_Goto (Raise_S, Goto_L1);
761 -- Add a goto L3 at end of statement list in block. The
762 -- first time, this is what skips over the exception
763 -- handlers in the normal case. Subsequent times, it
764 -- terminates the execution of the previous handler code,
765 -- and skips subsequent handlers.
767 Stmts := Statements (HSS);
769 Insert_After (Last (Stmts), Goto_L3);
770 Set_Analyzed (Goto_L3);
771 Set_Etype (Name_L3, Standard_Void_Type);
773 -- Now we drop the label that marks the handler start,
774 -- followed by the statements of the handler.
776 Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
778 Insert_After_And_Analyze (Last (Stmts), Labl_L1);
781 Loc : constant Source_Ptr := Sloc (First (H_Stmts));
782 Blk : constant Node_Id :=
783 Make_Block_Statement (Loc,
784 Handled_Statement_Sequence =>
785 Make_Handled_Sequence_Of_Statements (Loc,
786 Statements => H_Stmts));
788 Set_Exception_Junk (Blk);
789 Insert_After_And_Analyze (Last (Stmts), Blk);
793 -- Here if we have local raise statements but the handler is
794 -- not suitable for processing with a local raise. In this
795 -- case we have to generate possible diagnostics.
797 elsif Has_Local_Raise (Handler)
798 and then Local_Raise_Statements (Handler) /= No_Elist
800 Relmt := First_Elmt (Local_Raise_Statements (Handler));
801 while Present (Relmt) loop
802 Warn_If_No_Propagation (Node (Relmt));
810 -- Only remaining step is to drop the L3 label and we are done
812 Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
814 -- If we had at least one handler, then we drop the label after
815 -- the last statement of that handler.
817 if Stmts /= No_List then
818 Insert_After_And_Analyze (Last (Stmts), Labl_L3);
820 -- Otherwise we have removed all the handlers (this results from
821 -- use of pragma Restrictions (No_Exception_Propagation), and we
822 -- drop the label at the end of the statements of the HSS.
825 Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
830 end Expand_Local_Exception_Handlers;
832 -----------------------------
833 -- Prepend_Call_To_Handler --
834 -----------------------------
836 procedure Prepend_Call_To_Handler
838 Args : List_Id := No_List)
840 Ent : constant Entity_Id := RTE (Proc);
843 -- If we have no Entity, then we are probably in no run time mode
844 -- or some weird error has occured. In either case do do nothing!
846 if Present (Ent) then
848 Call : constant Node_Id :=
849 Make_Procedure_Call_Statement (Loc,
850 Name => New_Occurrence_Of (RTE (Proc), Loc),
851 Parameter_Associations => Args);
854 Prepend_To (Statements (Handler), Call);
855 Analyze (Call, Suppress => All_Checks);
858 end Prepend_Call_To_Handler;
860 ---------------------------
861 -- Replace_Raise_By_Goto --
862 ---------------------------
864 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
865 Loc : constant Source_Ptr := Sloc (Raise_S);
872 -- If we have a null statement, it means that there is no replacement
873 -- needed (typically this results from a suppressed check).
875 if Nkind (Raise_S) = N_Null_Statement then
878 -- Test for Raise_xxx_Error
880 elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
881 Excep := Standard_Constraint_Error;
882 Cond := Condition (Raise_S);
884 elsif Nkind (Raise_S) = N_Raise_Storage_Error then
885 Excep := Standard_Storage_Error;
886 Cond := Condition (Raise_S);
888 elsif Nkind (Raise_S) = N_Raise_Program_Error then
889 Excep := Standard_Program_Error;
890 Cond := Condition (Raise_S);
892 -- The only other possibility is a node that is or used to be a
893 -- simple raise statement.
896 Orig := Original_Node (Raise_S);
897 pragma Assert (Nkind (Orig) = N_Raise_Statement
898 and then Present (Name (Orig))
899 and then No (Expression (Orig)));
900 Excep := Entity (Name (Orig));
904 -- Here Excep is the exception to raise, and Cond is the condition
905 -- First prepare the call to Local_Raise (excep'address).
907 if RTE_Available (RE_Local_Raise) then
909 Make_Procedure_Call_Statement (Loc,
910 Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
911 Parameter_Associations => New_List (
912 Unchecked_Convert_To (RTE (RE_Address),
913 Make_Attribute_Reference (Loc,
914 Prefix => New_Occurrence_Of (Excep, Loc),
915 Attribute_Name => Name_Identity))));
917 -- Use null statement if Local_Raise not available
921 Make_Null_Statement (Loc);
924 -- If there is no condition, we rewrite as
927 -- Local_Raise (excep'Identity);
933 Make_Block_Statement (Loc,
934 Handled_Statement_Sequence =>
935 Make_Handled_Sequence_Of_Statements (Loc,
936 Statements => New_List (LR, Goto_L1))));
937 Set_Exception_Junk (Raise_S);
939 -- If there is a condition, we rewrite as
942 -- Local_Raise (excep'Identity);
948 Make_If_Statement (Loc,
950 Then_Statements => New_List (LR, Goto_L1)));
954 end Replace_Raise_By_Goto;
956 -- Start of processing for Expand_Exception_Handlers
959 Expand_Local_Exception_Handlers;
961 -- Loop through handlers
963 Handler := First_Non_Pragma (Handlrs);
964 Handler_Loop : while Present (Handler) loop
965 Next_Handler := Next_Non_Pragma (Handler);
967 -- Remove source handler if gnat debug flag N is set
969 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
972 -- Remove handler if no exception propagation, generating a warning
973 -- if a source generated handler was not the target of a local raise.
975 elsif Restriction_Active (No_Exception_Propagation) then
976 if not Has_Local_Raise (Handler)
977 and then Comes_From_Source (Handler)
978 and then Warn_On_Non_Local_Exception
980 Warn_No_Exception_Propagation_Active (Handler);
982 ("\?this handler can never be entered, and has been removed",
988 -- Exception handler is active and retained and must be processed
991 -- If an exception occurrence is present, then we must declare it
992 -- and initialize it from the value stored in the TSD
995 -- name : Exception_Occurrence;
997 -- Save_Occurrence (name, Get_Current_Excep.all)
1001 if Present (Choice_Parameter (Handler)) then
1003 Cparm : constant Entity_Id := Choice_Parameter (Handler);
1004 Clc : constant Source_Ptr := Sloc (Cparm);
1009 Make_Procedure_Call_Statement (Loc,
1011 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
1012 Parameter_Associations => New_List (
1013 New_Occurrence_Of (Cparm, Clc),
1014 Make_Explicit_Dereference (Loc,
1015 Make_Function_Call (Loc,
1016 Name => Make_Explicit_Dereference (Loc,
1018 (RTE (RE_Get_Current_Excep), Loc))))));
1020 Mark_Rewrite_Insertion (Save);
1021 Prepend (Save, Statements (Handler));
1024 Make_Object_Declaration
1026 Defining_Identifier => Cparm,
1027 Object_Definition =>
1029 (RTE (RE_Exception_Occurrence), Clc));
1030 Set_No_Initialization (Obj_Decl, True);
1033 Make_Implicit_Exception_Handler (Loc,
1034 Exception_Choices => Exception_Choices (Handler),
1036 Statements => New_List (
1037 Make_Block_Statement (Loc,
1038 Declarations => New_List (Obj_Decl),
1039 Handled_Statement_Sequence =>
1040 Make_Handled_Sequence_Of_Statements (Loc,
1041 Statements => Statements (Handler))))));
1043 Analyze_List (Statements (Handler), Suppress => All_Checks);
1047 -- The processing at this point is rather different for the JVM
1048 -- case, so we completely separate the processing.
1050 -- For the JVM case, we unconditionally call Update_Exception,
1051 -- passing a call to the intrinsic Current_Target_Exception (see
1052 -- JVM version of Ada.Exceptions in 4jexcept.adb for details).
1054 if VM_Target /= No_VM then
1056 Arg : constant Node_Id :=
1057 Make_Function_Call (Loc,
1060 (RTE (RE_Current_Target_Exception), Loc));
1062 Prepend_Call_To_Handler
1063 (RE_Update_Exception, New_List (Arg));
1066 -- For the normal case, we have to worry about the state of
1067 -- abort deferral. Generally, we defer abort during runtime
1068 -- handling of exceptions. When control is passed to the
1069 -- handler, then in the normal case we undefer aborts. In any
1070 -- case this entire handling is relevant only if aborts are
1073 elsif Abort_Allowed then
1075 -- There are some special cases in which we do not do the
1076 -- undefer. In particular a finalization (AT END) handler
1077 -- wants to operate with aborts still deferred.
1079 -- We also suppress the call if this is the special handler
1080 -- for Abort_Signal, since if we are aborting, we want to keep
1081 -- aborts deferred (one abort is enough).
1083 -- If abort really needs to be deferred the expander must add
1084 -- this call explicitly, see Expand_N_Asynchronous_Select.
1087 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
1090 or else Entity (First (Exception_Choices (Handler))) /=
1094 and then All_Others (First (Exception_Choices (Handler))))
1095 and then Abort_Allowed
1097 Prepend_Call_To_Handler (RE_Abort_Undefer);
1102 Handler := Next_Handler;
1103 end loop Handler_Loop;
1105 -- If all handlers got removed, then remove the list. Note we cannot
1106 -- reference HSS here, since expanding local handlers may have buried
1107 -- the handlers in an inner block.
1109 if Is_Empty_List (Handlrs) then
1110 Set_Exception_Handlers (Parent (Handlrs), No_List);
1112 end Expand_Exception_Handlers;
1114 ------------------------------------
1115 -- Expand_N_Exception_Declaration --
1116 ------------------------------------
1119 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1120 -- except : exception_data := (
1121 -- Handled_By_Other => False,
1123 -- Name_Length => exceptE'Length,
1124 -- Full_Name => exceptE'Address,
1125 -- HTable_Ptr => null,
1126 -- Import_Code => 0,
1127 -- Raise_Hook => null,
1130 -- (protecting test only needed if not at library level)
1132 -- exceptF : Boolean := True -- static data
1134 -- exceptF := False;
1135 -- Register_Exception (except'Unchecked_Access);
1138 procedure Expand_N_Exception_Declaration (N : Node_Id) is
1139 Loc : constant Source_Ptr := Sloc (N);
1140 Id : constant Entity_Id := Defining_Identifier (N);
1141 L : List_Id := New_List;
1142 Flag_Id : Entity_Id;
1144 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1145 Exname : constant Node_Id :=
1146 Make_Defining_Identifier (Loc, Name_Exname);
1149 -- There is no expansion needed when compiling for the JVM since the
1150 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
1152 if VM_Target /= No_VM then
1156 -- Definition of the external name: nam : constant String := "A.B.NAME";
1159 Make_Object_Declaration (Loc,
1160 Defining_Identifier => Exname,
1161 Constant_Present => True,
1162 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1163 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
1165 Set_Is_Statically_Allocated (Exname);
1167 -- Create the aggregate list for type Standard.Exception_Type:
1168 -- Handled_By_Other component: False
1170 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1172 -- Lang component: 'A'
1175 Make_Character_Literal (Loc,
1177 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
1179 -- Name_Length component: Nam'Length
1182 Make_Attribute_Reference (Loc,
1183 Prefix => New_Occurrence_Of (Exname, Loc),
1184 Attribute_Name => Name_Length));
1186 -- Full_Name component: Standard.A_Char!(Nam'Address)
1188 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1189 Make_Attribute_Reference (Loc,
1190 Prefix => New_Occurrence_Of (Exname, Loc),
1191 Attribute_Name => Name_Address)));
1193 -- HTable_Ptr component: null
1195 Append_To (L, Make_Null (Loc));
1197 -- Import_Code component: 0
1199 Append_To (L, Make_Integer_Literal (Loc, 0));
1201 -- Raise_Hook component: null
1203 Append_To (L, Make_Null (Loc));
1205 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1206 Analyze_And_Resolve (Expression (N), Etype (Id));
1208 -- Register_Exception (except'Unchecked_Access);
1210 if not No_Exception_Handlers_Set
1211 and then not Restriction_Active (No_Exception_Registration)
1214 Make_Procedure_Call_Statement (Loc,
1215 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1216 Parameter_Associations => New_List (
1217 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1218 Make_Attribute_Reference (Loc,
1219 Prefix => New_Occurrence_Of (Id, Loc),
1220 Attribute_Name => Name_Unrestricted_Access)))));
1222 Set_Register_Exception_Call (Id, First (L));
1224 if not Is_Library_Level_Entity (Id) then
1225 Flag_Id := Make_Defining_Identifier (Loc,
1226 New_External_Name (Chars (Id), 'F'));
1229 Make_Object_Declaration (Loc,
1230 Defining_Identifier => Flag_Id,
1231 Object_Definition =>
1232 New_Occurrence_Of (Standard_Boolean, Loc),
1234 New_Occurrence_Of (Standard_True, Loc)));
1236 Set_Is_Statically_Allocated (Flag_Id);
1239 Make_Assignment_Statement (Loc,
1240 Name => New_Occurrence_Of (Flag_Id, Loc),
1241 Expression => New_Occurrence_Of (Standard_False, Loc)));
1243 Insert_After_And_Analyze (N,
1244 Make_Implicit_If_Statement (N,
1245 Condition => New_Occurrence_Of (Flag_Id, Loc),
1246 Then_Statements => L));
1249 Insert_List_After_And_Analyze (N, L);
1253 end Expand_N_Exception_Declaration;
1255 ---------------------------------------------
1256 -- Expand_N_Handled_Sequence_Of_Statements --
1257 ---------------------------------------------
1259 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1261 -- Expand exception handlers
1263 if Present (Exception_Handlers (N))
1264 and then not Restriction_Active (No_Exception_Handlers)
1266 Expand_Exception_Handlers (N);
1269 -- If local exceptions are being expanded, the previous call will
1270 -- have rewritten the construct as a block and reanalyzed it. No
1271 -- further expansion is needed.
1273 if Analyzed (N) then
1277 -- Add clean up actions if required
1279 if Nkind (Parent (N)) /= N_Package_Body
1280 and then Nkind (Parent (N)) /= N_Accept_Statement
1281 and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1282 and then not Delay_Cleanups (Current_Scope)
1284 Expand_Cleanup_Actions (Parent (N));
1286 Set_First_Real_Statement (N, First (Statements (N)));
1288 end Expand_N_Handled_Sequence_Of_Statements;
1290 -------------------------------------
1291 -- Expand_N_Raise_Constraint_Error --
1292 -------------------------------------
1294 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1296 -- We adjust the condition to deal with the C/Fortran boolean case. This
1297 -- may well not be necessary, as all such conditions are generated by
1298 -- the expander and probably are all standard boolean, but who knows
1299 -- what strange optimization in future may require this adjustment!
1301 Adjust_Condition (Condition (N));
1303 -- Now deal with possible local raise handling
1305 Possible_Local_Raise (N, Standard_Constraint_Error);
1306 end Expand_N_Raise_Constraint_Error;
1308 ----------------------------------
1309 -- Expand_N_Raise_Program_Error --
1310 ----------------------------------
1312 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1314 -- We adjust the condition to deal with the C/Fortran boolean case. This
1315 -- may well not be necessary, as all such conditions are generated by
1316 -- the expander and probably are all standard boolean, but who knows
1317 -- what strange optimization in future may require this adjustment!
1319 Adjust_Condition (Condition (N));
1321 -- Now deal with possible local raise handling
1323 Possible_Local_Raise (N, Standard_Program_Error);
1324 end Expand_N_Raise_Program_Error;
1326 ------------------------------
1327 -- Expand_N_Raise_Statement --
1328 ------------------------------
1330 procedure Expand_N_Raise_Statement (N : Node_Id) is
1331 Loc : constant Source_Ptr := Sloc (N);
1338 -- Debug_Flag_Dot_G := True;
1340 -- Processing for locally handled exception (exclude reraise case)
1342 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1344 or else Restriction_Active (No_Exception_Propagation)
1346 -- If we have a local handler, then note that this is potentially
1347 -- able to be transformed into a goto statement.
1349 H := Find_Local_Handler (Entity (Name (N)), N);
1352 if Local_Raise_Statements (H) = No_Elist then
1353 Set_Local_Raise_Statements (H, New_Elmt_List);
1356 -- Append the new entry if it is not there already. Sometimes
1357 -- we have situations where due to reexpansion, the same node
1358 -- is analyzed twice and would otherwise be added twice.
1360 Append_Unique_Elmt (N, Local_Raise_Statements (H));
1361 Set_Has_Local_Raise (H);
1363 -- If no local handler, then generate no propagation warning
1366 Warn_If_No_Propagation (N);
1372 -- If a string expression is present, then the raise statement is
1373 -- converted to a call:
1375 -- Raise_Exception (exception-name'Identity, string);
1377 -- and there is nothing else to do
1379 if Present (Expression (N)) then
1381 Make_Procedure_Call_Statement (Loc,
1382 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1383 Parameter_Associations => New_List (
1384 Make_Attribute_Reference (Loc,
1386 Attribute_Name => Name_Identity),
1392 -- Remaining processing is for the case where no string expression
1395 -- There is no expansion needed for statement "raise <exception>;" when
1396 -- compiling for the JVM since the JVM has a built-in exception
1397 -- mechanism. However we need to keep the expansion for "raise;"
1398 -- statements. See 4jexcept.ads for details.
1400 if Present (Name (N)) and then VM_Target /= No_VM then
1404 -- Don't expand a raise statement that does not come from source
1405 -- if we have already had configurable run-time violations, since
1406 -- most likely it will be junk cascaded nonsense.
1408 if Configurable_Run_Time_Violations > 0
1409 and then not Comes_From_Source (N)
1414 -- Convert explicit raise of Program_Error, Constraint_Error, and
1415 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1416 -- all other raises will get normal expansion and be disallowed,
1417 -- but this is also faster in all modes).
1419 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1420 if Entity (Name (N)) = Standard_Constraint_Error then
1422 Make_Raise_Constraint_Error (Loc,
1423 Reason => CE_Explicit_Raise));
1427 elsif Entity (Name (N)) = Standard_Program_Error then
1429 Make_Raise_Program_Error (Loc,
1430 Reason => PE_Explicit_Raise));
1434 elsif Entity (Name (N)) = Standard_Storage_Error then
1436 Make_Raise_Storage_Error (Loc,
1437 Reason => SE_Explicit_Raise));
1443 -- Case of name present, in this case we expand raise name to
1445 -- Raise_Exception (name'Identity, location_string);
1447 -- where location_string identifies the file/line of the raise
1449 if Present (Name (N)) then
1451 Id : Entity_Id := Entity (Name (N));
1454 Build_Location_String (Loc);
1456 -- If the exception is a renaming, use the exception that it
1457 -- renames (which might be a predefined exception, e.g.).
1459 if Present (Renamed_Object (Id)) then
1460 Id := Renamed_Object (Id);
1463 -- Build a C-compatible string in case of no exception handlers,
1464 -- since this is what the last chance handler is expecting.
1466 if No_Exception_Handlers_Set then
1468 -- Generate an empty message if configuration pragma
1469 -- Suppress_Exception_Locations is set for this unit.
1471 if Opt.Exception_Locations_Suppressed then
1474 Name_Len := Name_Len + 1;
1477 Name_Buffer (Name_Len) := ASCII.NUL;
1480 if Opt.Exception_Locations_Suppressed then
1484 Str := String_From_Name_Buffer;
1486 -- For VMS exceptions, convert the raise into a call to
1487 -- lib$stop so it will be handled by __gnat_error_handler.
1489 if Is_VMS_Exception (Id) then
1491 Excep_Image : String_Id;
1495 if Present (Interface_Name (Id)) then
1496 Excep_Image := Strval (Interface_Name (Id));
1498 Get_Name_String (Chars (Id));
1500 Excep_Image := String_From_Name_Buffer;
1503 if Exception_Code (Id) /= No_Uint then
1505 Make_Integer_Literal (Loc, Exception_Code (Id));
1508 Unchecked_Convert_To (Standard_Integer,
1509 Make_Function_Call (Loc,
1510 Name => New_Occurrence_Of
1511 (RTE (RE_Import_Value), Loc),
1512 Parameter_Associations => New_List
1513 (Make_String_Literal (Loc,
1514 Strval => Excep_Image))));
1518 Make_Procedure_Call_Statement (Loc,
1520 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1521 Parameter_Associations => New_List (Cond)));
1522 Analyze_And_Resolve (Cond, Standard_Integer);
1525 -- Not VMS exception case, convert raise to call to the
1526 -- Raise_Exception routine.
1530 Make_Procedure_Call_Statement (Loc,
1531 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1532 Parameter_Associations => New_List (
1533 Make_Attribute_Reference (Loc,
1535 Attribute_Name => Name_Identity),
1536 Make_String_Literal (Loc,
1541 -- Case of no name present (reraise). We rewrite the raise to:
1543 -- Reraise_Occurrence_Always (EO);
1545 -- where EO is the current exception occurrence. If the current handler
1546 -- does not have a choice parameter specification, then we provide one.
1549 -- Find innermost enclosing exception handler (there must be one,
1550 -- since the semantics has already verified that this raise statement
1551 -- is valid, and a raise with no arguments is only permitted in the
1552 -- context of an exception handler.
1554 Ehand := Parent (N);
1555 while Nkind (Ehand) /= N_Exception_Handler loop
1556 Ehand := Parent (Ehand);
1559 -- Make exception choice parameter if none present. Note that we do
1560 -- not need to put the entity on the entity chain, since no one will
1561 -- be referencing this entity by normal visibility methods.
1563 if No (Choice_Parameter (Ehand)) then
1564 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1565 Set_Choice_Parameter (Ehand, E);
1566 Set_Ekind (E, E_Variable);
1567 Set_Etype (E, RTE (RE_Exception_Occurrence));
1568 Set_Scope (E, Current_Scope);
1571 -- Now rewrite the raise as a call to Reraise. A special case arises
1572 -- if this raise statement occurs in the context of a handler for
1573 -- all others (i.e. an at end handler). in this case we avoid
1574 -- the call to defer abort, cleanup routines are expected to be
1575 -- called in this case with aborts deferred.
1578 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1582 if Nkind (Ech) = N_Others_Choice
1583 and then All_Others (Ech)
1585 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1587 Ent := RTE (RE_Reraise_Occurrence_Always);
1591 Make_Procedure_Call_Statement (Loc,
1592 Name => New_Occurrence_Of (Ent, Loc),
1593 Parameter_Associations => New_List (
1594 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1599 end Expand_N_Raise_Statement;
1601 ----------------------------------
1602 -- Expand_N_Raise_Storage_Error --
1603 ----------------------------------
1605 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1607 -- We adjust the condition to deal with the C/Fortran boolean case. This
1608 -- may well not be necessary, as all such conditions are generated by
1609 -- the expander and probably are all standard boolean, but who knows
1610 -- what strange optimization in future may require this adjustment!
1612 Adjust_Condition (Condition (N));
1614 -- Now deal with possible local raise handling
1616 Possible_Local_Raise (N, Standard_Storage_Error);
1617 end Expand_N_Raise_Storage_Error;
1619 --------------------------
1620 -- Possible_Local_Raise --
1621 --------------------------
1623 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1625 -- Nothing to do if local raise optimization not active
1627 if not Debug_Flag_Dot_G
1628 and then not Restriction_Active (No_Exception_Propagation)
1633 -- Nothing to do if original node was an explicit raise, because in
1634 -- that case, we already generated the required warning for the raise.
1636 if Nkind (Original_Node (N)) = N_Raise_Statement then
1640 -- Otherwise see if we have a local handler for the exception
1643 H : constant Node_Id := Find_Local_Handler (E, N);
1646 -- If so, mark that it has a local raise
1649 Set_Has_Local_Raise (H, True);
1651 -- Otherwise, if the No_Exception_Propagation restriction is active
1652 -- and the warning is enabled, generate the appropriate warnings.
1654 elsif Warn_On_Non_Local_Exception
1655 and then Restriction_Active (No_Exception_Propagation)
1657 Warn_No_Exception_Propagation_Active (N);
1659 if Configurable_Run_Time_Mode then
1661 ("\?& may call Last_Chance_Handler", N, E);
1664 ("\?& may result in unhandled exception", N, E);
1668 end Possible_Local_Raise;
1670 ------------------------------
1671 -- Expand_N_Subprogram_Info --
1672 ------------------------------
1674 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1675 Loc : constant Source_Ptr := Sloc (N);
1678 -- For now, we replace an Expand_N_Subprogram_Info node with an
1679 -- attribute reference that gives the address of the procedure.
1680 -- This is because gigi does not yet recognize this node, and
1681 -- for the initial targets, this is the right value anyway.
1684 Make_Attribute_Reference (Loc,
1685 Prefix => Identifier (N),
1686 Attribute_Name => Name_Code_Address));
1688 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1689 end Expand_N_Subprogram_Info;
1691 ------------------------
1692 -- Find_Local_Handler --
1693 ------------------------
1695 function Find_Local_Handler
1697 Nod : Node_Id) return Node_Id
1704 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1705 -- This is used to test for wrapped actions below
1708 EHandle : Entity_Id;
1709 -- The entity Id's for the exception we are raising and handling, using
1710 -- the renamed exception if a Renamed_Entity is present.
1713 -- Never any local handler if all handlers removed
1715 if Debug_Flag_Dot_X then
1719 -- Get the exception we are raising, allowing for renaming
1721 ERaise := Get_Renamed_Entity (Ename);
1723 -- We need to check if the node we are looking at is contained in
1726 -- Loop to search up the tree
1732 -- If we get to the top of the tree, or to a subprogram, task, entry,
1733 -- protected body, or accept statement without having found a
1734 -- matching handler, then there is no local handler.
1737 or else Nkind (P) = N_Subprogram_Body
1738 or else Nkind (P) = N_Task_Body
1739 or else Nkind (P) = N_Protected_Body
1740 or else Nkind (P) = N_Entry_Body
1741 or else Nkind (P) = N_Accept_Statement
1745 -- Test for handled sequence of statements with at least one
1746 -- exception handler which might be the one we are looking for.
1748 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1749 and then Present (Exception_Handlers (P))
1751 -- Before we proceed we need to check if the node N is covered
1752 -- by the statement part of P rather than one of its exception
1753 -- handlers (an exception handler obviously does not cover its
1756 -- This test is more delicate than might be thought. It is not
1757 -- just a matter of checking the Statements (P), because the node
1758 -- might be waiting to be wrapped in a transient scope, in which
1759 -- case it will end up in the block statements, even though it
1760 -- is not there now.
1762 if Is_List_Member (N)
1763 and then (List_Containing (N) = Statements (P)
1765 List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
1767 List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
1769 -- Loop through exception handlers
1771 H := First (Exception_Handlers (P));
1772 while Present (H) loop
1774 -- Loop through choices in one handler
1776 C := First (Exception_Choices (H));
1777 while Present (C) loop
1779 -- Deal with others case
1781 if Nkind (C) = N_Others_Choice then
1783 -- Matching others handler, but we need to ensure
1784 -- there is no choice parameter. If there is, then we
1785 -- don't have a local handler after all (since we do
1786 -- not allow choice parameters for local handlers).
1788 if No (Choice_Parameter (H)) then
1794 -- If not others must be entity name
1796 elsif Nkind (C) /= N_Others_Choice then
1797 pragma Assert (Is_Entity_Name (C));
1798 pragma Assert (Present (Entity (C)));
1800 -- Get exception being handled, dealing with renaming
1802 EHandle := Get_Renamed_Entity (Entity (C));
1804 -- If match, then check choice parameter
1806 if ERaise = EHandle then
1807 if No (Choice_Parameter (H)) then
1825 end Find_Local_Handler;
1827 ---------------------------------
1828 -- Get_Local_Raise_Call_Entity --
1829 ---------------------------------
1831 -- Note: this is primary provided for use by the back end in generating
1832 -- calls to Local_Raise. But it would be too late in the back end to call
1833 -- RTE if this actually caused a load/analyze of the unit. So what we do
1834 -- is to ensure there is a dummy call to this function during front end
1835 -- processing so that the unit gets loaded then, and not later.
1837 Local_Raise_Call_Entity : Entity_Id;
1838 Local_Raise_Call_Entity_Set : Boolean := False;
1840 function Get_Local_Raise_Call_Entity return Entity_Id is
1842 if not Local_Raise_Call_Entity_Set then
1843 Local_Raise_Call_Entity_Set := True;
1845 if RTE_Available (RE_Local_Raise) then
1846 Local_Raise_Call_Entity := RTE (RE_Local_Raise);
1848 Local_Raise_Call_Entity := Empty;
1852 return Local_Raise_Call_Entity;
1853 end Get_Local_Raise_Call_Entity;
1855 -----------------------------
1856 -- Get_RT_Exception_Entity --
1857 -----------------------------
1859 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
1862 when RT_CE_Exceptions => return Standard_Constraint_Error;
1863 when RT_PE_Exceptions => return Standard_Program_Error;
1864 when RT_SE_Exceptions => return Standard_Storage_Error;
1866 end Get_RT_Exception_Entity;
1868 ----------------------
1869 -- Is_Non_Ada_Error --
1870 ----------------------
1872 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1874 if not OpenVMS_On_Target then
1878 Get_Name_String (Chars (E));
1880 -- Note: it is a little irregular for the body of exp_ch11 to know
1881 -- the details of the encoding scheme for names, but on the other
1882 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1884 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1889 end Is_Non_Ada_Error;
1891 ----------------------------
1892 -- Warn_If_No_Propagation --
1893 ----------------------------
1895 procedure Warn_If_No_Propagation (N : Node_Id) is
1897 if Restriction_Active (No_Exception_Propagation)
1898 and then Warn_On_Non_Local_Exception
1900 Warn_No_Exception_Propagation_Active (N);
1902 if Configurable_Run_Time_Mode then
1904 ("\?Last_Chance_Handler will be called on exception", N);
1907 ("\?execution may raise unhandled exception", N);
1910 end Warn_If_No_Propagation;
1912 ------------------------------------------
1913 -- Warn_No_Exception_Propagation_Active --
1914 ------------------------------------------
1916 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
1919 ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
1920 end Warn_No_Exception_Propagation_Active;