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)),
146 Make_Raise_Statement (Loc));
148 Set_Exception_Handlers (HSS, New_List (
149 Make_Implicit_Exception_Handler (Loc,
150 Exception_Choices => New_List (Ohandle),
151 Statements => Stmnts)));
153 Analyze_List (Stmnts, Suppress => All_Checks);
154 Expand_Exception_Handlers (HSS);
156 if Present (Block) then
159 end Expand_At_End_Handler;
161 -------------------------------
162 -- Expand_Exception_Handlers --
163 -------------------------------
165 procedure Expand_Exception_Handlers (HSS : Node_Id) is
166 Handlrs : constant List_Id := Exception_Handlers (HSS);
167 Loc : constant Source_Ptr := Sloc (HSS);
169 Others_Choice : Boolean;
171 Next_Handler : Node_Id;
173 procedure Expand_Local_Exception_Handlers;
174 -- This procedure handles the expansion of exception handlers for the
175 -- optimization of local raise statements into goto statements.
177 procedure Prepend_Call_To_Handler
179 Args : List_Id := No_List);
180 -- Routine to prepend a call to the procedure referenced by Proc at
181 -- the start of the handler code for the current Handler.
183 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
184 -- Raise_S is a raise statement (possibly expanded, and possibly of the
185 -- form of a Raise_xxx_Error node with a condition. This procedure is
186 -- called to replace the raise action with the (already analyzed) goto
187 -- statement passed as Goto_L1. This procedure also takes care of the
188 -- requirement of inserting a Local_Raise call where possible.
190 -------------------------------------
191 -- Expand_Local_Exception_Handlers --
192 -------------------------------------
194 -- There are two cases for this transformation. First the case of
195 -- explicit raise statements. For this case, the transformation we do
196 -- looks like this. Right now we have for example (where L1, L2 are
201 -- raise_exception (excep1'identity); -- was raise excep1
203 -- raise_exception (excep2'identity); -- was raise excep2
212 -- This gets transformed into:
215 -- L1 : label; -- marked Exception_Junk
216 -- L2 : label; -- marked Exception_Junk
217 -- L3 : label; -- marked Exception_Junk
219 -- begin -- marked Exception_Junk
221 -- local_raise (excep1'address); -- was raise excep1
224 -- local_raise (excep2'address); -- was raise excep2
234 -- goto L3; -- skip handler if no raise, marked Exception_Junk
236 -- <<L1>> -- local excep target label, marked Exception_Junk
237 -- begin -- marked Exception_Junk
240 -- goto L3; -- marked Exception_Junk
242 -- <<L2>> -- marked Exception_Junk
243 -- begin -- marked Exception_Junk
246 -- goto L3; -- marked Exception_Junk
247 -- <<L3>> -- marked Exception_Junk
250 -- Note: the reason we wrap the original statement sequence in an
251 -- inner block is that there may be raise statements within the
252 -- sequence of statements in the handlers, and we must ensure that
253 -- these are properly handled, and in particular, such raise statements
254 -- must not reenter the same exception handlers.
256 -- If the restriction No_Exception_Propagation is in effect, then we
257 -- can omit the exception handlers.
260 -- L1 : label; -- marked Exception_Junk
261 -- L2 : label; -- marked Exception_Junk
262 -- L3 : label; -- marked Exception_Junk
264 -- begin -- marked Exception_Junk
266 -- local_raise (excep1'address); -- was raise excep1
269 -- local_raise (excep2'address); -- was raise excep2
274 -- goto L3; -- skip handler if no raise, marked Exception_Junk
276 -- <<L1>> -- local excep target label, marked Exception_Junk
277 -- begin -- marked Exception_Junk
280 -- goto L3; -- marked Exception_Junk
282 -- <<L2>> -- marked Exception_Junk
283 -- begin -- marked Exception_Junk
287 -- <<L3>> -- marked Exception_Junk
290 -- The second case is for exceptions generated by the back end in one
291 -- of three situations:
293 -- 1. Front end generates N_Raise_xxx_Error node
294 -- 2. Front end sets Do_xxx_Check flag in subexpression node
295 -- 3. Back end detects a situation where an exception is appropriate
297 -- In all these cases, the current processing in gigi is to generate a
298 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
299 -- exception message and the exception to be raised, Constraint_Error,
300 -- Program_Error, or Storage_Error.
302 -- We could handle some subcases of 1 using the same front end expansion
303 -- into gotos, but even for case 1, we can't handle all cases, since
304 -- generating gotos in the middle of expressions is not possible (it's
305 -- possible at the gigi/gcc level, but not at the level of the GNAT
308 -- In any case, it seems easier to have a scheme which handles all three
309 -- cases in a uniform manner. So here is how we proceed in this case.
311 -- This procedure detects all handlers for these three exceptions,
312 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
313 -- OTHERS handlers that cover one or more of these cases).
315 -- If the handler meets the requirements for being the target of a local
316 -- raise, then the front end does the expansion described previously,
317 -- creating a label to be used as a goto target to raise the exception.
318 -- However, no attempt is made in the front end to convert any related
319 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
320 -- left unchanged and passed to the back end.
322 -- Instead, the front end generates two nodes
324 -- N_Push_Constraint_Error_Label
325 -- N_Push_Program_Error_Label
326 -- N_Push_Storage_Error_Label
328 -- The Push node is generated at the start of the statements
329 -- covered by the handler, and has as a parameter the label to be
330 -- used as the raise target.
332 -- N_Pop_Constraint_Error_Label
333 -- N_Pop_Program_Error_Label
334 -- N_Pop_Storage_Error_Label
336 -- The Pop node is generated at the end of the covered statements
337 -- and undoes the effect of the preceding corresponding Push node.
339 -- In the case where the handler does NOT meet the requirements, the
340 -- front end will still generate the Push and Pop nodes, but the label
341 -- field in the Push node will be empty signifying that for this region
342 -- of code, no optimization is possible.
344 -- The back end must maintain three stacks, one for each exception case,
345 -- the Push node pushes an entry onto the corresponding stack, and Pop
346 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
347 -- corresponding top stack entry has an non-empty label, a goto is
348 -- generated. This goto should be preceded by a call to Local_Raise as
351 -- An example of this transformation is as follows, given:
354 -- A : Integer range 1 .. 10;
358 -- when Constraint_Error =>
362 -- gets transformed to:
365 -- A : Integer range 1 .. 10;
372 -- %push_constraint_error_label (L1)
373 -- R1b : constant long_long_integer := long_long_integer?(b) +
374 -- long_long_integer?(c);
375 -- [constraint_error when
376 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
377 -- "overflow check failed"]
378 -- a := integer?(R1b);
379 -- %pop_constraint_error_Label
383 -- when constraint_error =>
387 -- goto L2; -- skip handler when exception not raised
388 -- <<L1>> -- target label for local exception
393 -- Note: the generated labels and goto statements all have the flag
394 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
395 -- this generated exception stuff when checking for missing return
396 -- statements (see circuitry in Check_Statement_Sequence).
398 -- Note: All of the processing described above occurs only if
399 -- restriction No_Exception_Propagation applies or debug flag .g is
402 CE_Locally_Handled : Boolean := False;
403 SE_Locally_Handled : Boolean := False;
404 PE_Locally_Handled : Boolean := False;
405 -- These three flags indicate whether a handler for the corresponding
406 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
407 -- is present. If so the switch is set to True, the Exception_Label
408 -- field of the corresponding handler is set, and appropriate Push
409 -- and Pop nodes are inserted into the code.
411 Local_Expansion_Required : Boolean := False;
412 -- Set True if we have at least one handler requiring local raise
413 -- expansion as described above.
415 procedure Expand_Local_Exception_Handlers is
417 procedure Add_Exception_Label (H : Node_Id);
418 -- H is an exception handler. First check for an Exception_Label
419 -- already allocated for H. If none, allocate one, set the field in
420 -- the handler node, add the label declaration, and set the flag
421 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
422 -- the call has no effect and Exception_Label is left empty.
424 procedure Add_Label_Declaration (L : Entity_Id);
425 -- Add an implicit declaration of the given label to the declaration
426 -- list in the parent of the current sequence of handled statements.
429 Exc_Locally_Handled : in out Boolean;
430 -- Flag indicating whether a local handler for this exception
431 -- has already been generated.
433 with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
434 -- Function to create a Push_xxx_Label node
436 with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
437 -- Function to create a Pop_xxx_Label node
439 procedure Generate_Push_Pop (H : Node_Id);
440 -- Common code for Generate_Push_Pop_xxx below, used to generate an
441 -- exception label and Push/Pop nodes for Constraint_Error,
442 -- Program_Error, or Storage_Error.
444 -------------------------
445 -- Add_Exception_Label --
446 -------------------------
448 procedure Add_Exception_Label (H : Node_Id) is
450 if No (Exception_Label (H))
451 and then not Local_Raise_Not_OK (H)
452 and then not Special_Exception_Package_Used
454 Local_Expansion_Required := True;
457 L : constant Entity_Id :=
458 Make_Defining_Identifier (Sloc (H),
459 Chars => New_Internal_Name ('L'));
461 Set_Exception_Label (H, L);
462 Add_Label_Declaration (L);
465 end Add_Exception_Label;
467 ---------------------------
468 -- Add_Label_Declaration --
469 ---------------------------
471 procedure Add_Label_Declaration (L : Entity_Id) is
472 P : constant Node_Id := Parent (HSS);
474 Decl_L : constant Node_Id :=
475 Make_Implicit_Label_Declaration (Loc,
476 Defining_Identifier => L);
479 if Declarations (P) = No_List then
480 Set_Declarations (P, Empty_List);
483 Append (Decl_L, Declarations (P));
485 end Add_Label_Declaration;
487 -----------------------
488 -- Generate_Push_Pop --
489 -----------------------
491 procedure Generate_Push_Pop (H : Node_Id) is
493 if Exc_Locally_Handled then
496 Exc_Locally_Handled := True;
499 Add_Exception_Label (H);
502 F : constant Node_Id := First (Statements (HSS));
503 L : constant Node_Id := Last (Statements (HSS));
505 Push : constant Node_Id := Make_Push_Label (Sloc (F));
506 Pop : constant Node_Id := Make_Pop_Label (Sloc (L));
509 -- We make sure that a call to Get_Local_Raise_Call_Entity is
510 -- made during front end processing, so that when we need it
511 -- in the back end, it will already be available and loaded.
513 Discard_Node (Get_Local_Raise_Call_Entity);
515 -- Prepare and insert Push and Pop nodes
517 Set_Exception_Label (Push, Exception_Label (H));
518 Insert_Before (F, Push);
521 Insert_After (L, Pop);
524 end Generate_Push_Pop;
526 -- Local declarations
528 Loc : constant Source_Ptr := Sloc (HSS);
529 Stmts : List_Id := No_List;
533 procedure Generate_Push_Pop_For_Constraint_Error is
534 new Generate_Push_Pop
535 (Exc_Locally_Handled => CE_Locally_Handled,
536 Make_Push_Label => Make_Push_Constraint_Error_Label,
537 Make_Pop_Label => Make_Pop_Constraint_Error_Label);
538 -- If no Push/Pop has been generated for CE yet, then set the flag
539 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
540 -- not already done), and generate Push/Pop nodes for the exception
541 -- label at the start and end of the statements of HSS.
543 procedure Generate_Push_Pop_For_Program_Error is
544 new Generate_Push_Pop
545 (Exc_Locally_Handled => PE_Locally_Handled,
546 Make_Push_Label => Make_Push_Program_Error_Label,
547 Make_Pop_Label => Make_Pop_Program_Error_Label);
548 -- If no Push/Pop has been generated for PE yet, then set the flag
549 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
550 -- not already done), and generate Push/Pop nodes for the exception
551 -- label at the start and end of the statements of HSS.
553 procedure Generate_Push_Pop_For_Storage_Error is
554 new Generate_Push_Pop
555 (Exc_Locally_Handled => SE_Locally_Handled,
556 Make_Push_Label => Make_Push_Storage_Error_Label,
557 Make_Pop_Label => Make_Pop_Storage_Error_Label);
558 -- If no Push/Pop has been generated for SE yet, then set the flag
559 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
560 -- not already done), and generate Push/Pop nodes for the exception
561 -- label at the start and end of the statements of HSS.
563 -- Start of processing for Expand_Local_Exception_Handlers
566 -- No processing if all exception handlers will get removed
568 if Debug_Flag_Dot_X then
572 -- See for each handler if we have any local raises to expand
574 Handler := First_Non_Pragma (Handlrs);
575 while Present (Handler) loop
577 -- Note, we do not test Local_Raise_Not_OK here, because in the
578 -- case of Push/Pop generation we want to generate push with a
579 -- null label. The Add_Exception_Label routine has no effect if
580 -- Local_Raise_Not_OK is set, so this works as required.
582 if Present (Local_Raise_Statements (Handler)) then
583 Add_Exception_Label (Handler);
586 -- If we are doing local raise to goto optimization (restriction
587 -- No_Exception_Propagation set or debug flag .g set), then check
588 -- to see if handler handles CE, PE, SE and if so generate the
589 -- appropriate push/pop sequence for the back end.
592 or else Restriction_Active (No_Exception_Propagation))
593 and then Has_Local_Raise (Handler)
595 Choice := First (Exception_Choices (Handler));
596 while Present (Choice) loop
597 if Nkind (Choice) = N_Others_Choice
598 and then not All_Others (Choice)
600 Generate_Push_Pop_For_Constraint_Error (Handler);
601 Generate_Push_Pop_For_Program_Error (Handler);
602 Generate_Push_Pop_For_Storage_Error (Handler);
604 elsif Is_Entity_Name (Choice) then
605 Excep := Get_Renamed_Entity (Entity (Choice));
607 if Excep = Standard_Constraint_Error then
608 Generate_Push_Pop_For_Constraint_Error (Handler);
609 elsif Excep = Standard_Program_Error then
610 Generate_Push_Pop_For_Program_Error (Handler);
611 elsif Excep = Standard_Storage_Error then
612 Generate_Push_Pop_For_Storage_Error (Handler);
620 Next_Non_Pragma (Handler);
623 -- Nothing to do if no handlers requiring the goto transformation
625 if not (Local_Expansion_Required) then
629 -- Prepare to do the transformation
632 -- L3 is the label to exit the HSS
634 L3_Dent : constant Entity_Id :=
635 Make_Defining_Identifier (Loc,
636 Chars => New_Internal_Name ('L'));
638 Labl_L3 : constant Node_Id :=
640 Identifier => New_Occurrence_Of (L3_Dent, Loc));
646 Set_Exception_Junk (Labl_L3);
647 Add_Label_Declaration (L3_Dent);
649 -- Wrap existing statements and handlers in an inner block
652 Make_Block_Statement (Loc,
653 Handled_Statement_Sequence => Relocate_Node (HSS));
654 Set_Exception_Junk (Blk_Stm);
657 Make_Handled_Sequence_Of_Statements (Loc,
658 Statements => New_List (Blk_Stm)));
660 -- Set block statement as analyzed, we don't want to actually call
661 -- Analyze on this block, it would cause a recursion in exception
662 -- handler processing which would mess things up.
664 Set_Analyzed (Blk_Stm);
666 -- Now loop through the exception handlers to deal with those that
667 -- are targets of local raise statements.
669 Handler := First_Non_Pragma (Handlrs);
670 while Present (Handler) loop
671 if Present (Exception_Label (Handler)) then
673 -- This handler needs the goto expansion
676 Loc : constant Source_Ptr := Sloc (Handler);
678 -- L1 is the start label for this handler
680 L1_Dent : constant Entity_Id := Exception_Label (Handler);
682 Labl_L1 : constant Node_Id :=
685 New_Occurrence_Of (L1_Dent, Loc));
687 -- Jump to L1 to be used as replacement for the original
688 -- handler (used in the case where exception propagation
691 Name_L1 : constant Node_Id :=
692 New_Occurrence_Of (L1_Dent, Loc);
694 Goto_L1 : constant Node_Id :=
695 Make_Goto_Statement (Loc,
698 -- Jump to L3 to be used at the end of handler
700 Name_L3 : constant Node_Id :=
701 New_Occurrence_Of (L3_Dent, Loc);
703 Goto_L3 : constant Node_Id :=
704 Make_Goto_Statement (Loc,
707 H_Stmts : constant List_Id := Statements (Handler);
710 Set_Exception_Junk (Labl_L1);
711 Set_Exception_Junk (Goto_L3);
713 -- Note: we do NOT set Exception_Junk in Goto_L1, since
714 -- this is a real transfer of control that we want the
715 -- Sem_Ch6.Check_Returns procedure to recognize properly.
717 -- Replace handler by a goto L1. We can mark this as
718 -- analyzed since it is fully formed, and we don't
719 -- want it going through any further checks. We save
720 -- the last statement location in the goto L1 node for
721 -- the benefit of Sem_Ch6.Check_Returns.
723 Set_Statements (Handler, New_List (Goto_L1));
724 Set_Analyzed (Goto_L1);
725 Set_Etype (Name_L1, Standard_Void_Type);
727 -- Now replace all the raise statements by goto L1
729 if Present (Local_Raise_Statements (Handler)) then
730 Relmt := First_Elmt (Local_Raise_Statements (Handler));
731 while Present (Relmt) loop
733 Raise_S : constant Node_Id := Node (Relmt);
735 Name_L1 : constant Node_Id :=
736 New_Occurrence_Of (L1_Dent, Loc);
738 Goto_L1 : constant Node_Id :=
739 Make_Goto_Statement (Loc,
743 -- Replace raise by goto L1
745 Set_Analyzed (Goto_L1);
746 Set_Etype (Name_L1, Standard_Void_Type);
747 Replace_Raise_By_Goto (Raise_S, Goto_L1);
754 -- Add a goto L3 at end of statement list in block. The
755 -- first time, this is what skips over the exception
756 -- handlers in the normal case. Subsequent times, it
757 -- terminates the execution of the previous handler code,
758 -- and skips subsequent handlers.
760 Stmts := Statements (HSS);
762 Insert_After (Last (Stmts), Goto_L3);
763 Set_Analyzed (Goto_L3);
764 Set_Etype (Name_L3, Standard_Void_Type);
766 -- Now we drop the label that marks the handler start,
767 -- followed by the statements of the handler.
769 Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
771 Insert_After_And_Analyze (Last (Stmts), Labl_L1);
774 Loc : constant Source_Ptr := Sloc (First (H_Stmts));
775 Blk : constant Node_Id :=
776 Make_Block_Statement (Loc,
777 Handled_Statement_Sequence =>
778 Make_Handled_Sequence_Of_Statements (Loc,
779 Statements => H_Stmts));
781 Set_Exception_Junk (Blk);
782 Insert_After_And_Analyze (Last (Stmts), Blk);
786 -- Here if we have local raise statements but the handler is
787 -- not suitable for processing with a local raise. In this
788 -- case we have to generate possible diagnostics.
790 elsif Has_Local_Raise (Handler)
791 and then Local_Raise_Statements (Handler) /= No_Elist
793 Relmt := First_Elmt (Local_Raise_Statements (Handler));
794 while Present (Relmt) loop
795 Warn_If_No_Propagation (Node (Relmt));
803 -- Only remaining step is to drop the L3 label and we are done
805 Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
807 -- If we had at least one handler, then we drop the label after
808 -- the last statement of that handler.
810 if Stmts /= No_List then
811 Insert_After_And_Analyze (Last (Stmts), Labl_L3);
813 -- Otherwise we have removed all the handlers (this results from
814 -- use of pragma Restrictions (No_Exception_Propagation), and we
815 -- drop the label at the end of the statements of the HSS.
818 Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
823 end Expand_Local_Exception_Handlers;
825 -----------------------------
826 -- Prepend_Call_To_Handler --
827 -----------------------------
829 procedure Prepend_Call_To_Handler
831 Args : List_Id := No_List)
833 Ent : constant Entity_Id := RTE (Proc);
836 -- If we have no Entity, then we are probably in no run time mode
837 -- or some weird error has occured. In either case do do nothing!
839 if Present (Ent) then
841 Call : constant Node_Id :=
842 Make_Procedure_Call_Statement (Loc,
843 Name => New_Occurrence_Of (RTE (Proc), Loc),
844 Parameter_Associations => Args);
847 Prepend_To (Statements (Handler), Call);
848 Analyze (Call, Suppress => All_Checks);
851 end Prepend_Call_To_Handler;
853 ---------------------------
854 -- Replace_Raise_By_Goto --
855 ---------------------------
857 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
858 Loc : constant Source_Ptr := Sloc (Raise_S);
865 -- If we have a null statement, it means that there is no replacement
866 -- needed (typically this results from a suppressed check).
868 if Nkind (Raise_S) = N_Null_Statement then
871 -- Test for Raise_xxx_Error
873 elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
874 Excep := Standard_Constraint_Error;
875 Cond := Condition (Raise_S);
877 elsif Nkind (Raise_S) = N_Raise_Storage_Error then
878 Excep := Standard_Storage_Error;
879 Cond := Condition (Raise_S);
881 elsif Nkind (Raise_S) = N_Raise_Program_Error then
882 Excep := Standard_Program_Error;
883 Cond := Condition (Raise_S);
885 -- The only other possibility is a node that is or used to be a
886 -- simple raise statement.
889 Orig := Original_Node (Raise_S);
890 pragma Assert (Nkind (Orig) = N_Raise_Statement
891 and then Present (Name (Orig))
892 and then No (Expression (Orig)));
893 Excep := Entity (Name (Orig));
897 -- Here Excep is the exception to raise, and Cond is the condition
898 -- First prepare the call to Local_Raise (excep'address).
900 if RTE_Available (RE_Local_Raise) then
902 Make_Procedure_Call_Statement (Loc,
903 Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
904 Parameter_Associations => New_List (
905 Unchecked_Convert_To (RTE (RE_Address),
906 Make_Attribute_Reference (Loc,
907 Prefix => New_Occurrence_Of (Excep, Loc),
908 Attribute_Name => Name_Identity))));
910 -- Use null statement if Local_Raise not available
914 Make_Null_Statement (Loc);
917 -- If there is no condition, we rewrite as
920 -- Local_Raise (excep'Identity);
926 Make_Block_Statement (Loc,
927 Handled_Statement_Sequence =>
928 Make_Handled_Sequence_Of_Statements (Loc,
929 Statements => New_List (LR, Goto_L1))));
930 Set_Exception_Junk (Raise_S);
932 -- If there is a condition, we rewrite as
935 -- Local_Raise (excep'Identity);
941 Make_If_Statement (Loc,
943 Then_Statements => New_List (LR, Goto_L1)));
947 end Replace_Raise_By_Goto;
949 -- Start of processing for Expand_Exception_Handlers
952 Expand_Local_Exception_Handlers;
954 -- Loop through handlers
956 Handler := First_Non_Pragma (Handlrs);
957 Handler_Loop : while Present (Handler) loop
958 Next_Handler := Next_Non_Pragma (Handler);
960 -- Remove source handler if gnat debug flag N is set
962 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
965 -- Remove handler if no exception propagation, generating a warning
966 -- if a source generated handler was not the target of a local raise.
968 elsif Restriction_Active (No_Exception_Propagation) then
969 if not Has_Local_Raise (Handler)
970 and then Comes_From_Source (Handler)
971 and then Warn_On_Non_Local_Exception
973 Warn_No_Exception_Propagation_Active (Handler);
975 ("\?this handler can never be entered, and has been removed",
981 -- Exception handler is active and retained and must be processed
984 -- If an exception occurrence is present, then we must declare it
985 -- and initialize it from the value stored in the TSD
988 -- name : Exception_Occurrence;
990 -- Save_Occurrence (name, Get_Current_Excep.all)
994 if Present (Choice_Parameter (Handler)) then
996 Cparm : constant Entity_Id := Choice_Parameter (Handler);
997 Clc : constant Source_Ptr := Sloc (Cparm);
1002 Make_Procedure_Call_Statement (Loc,
1004 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
1005 Parameter_Associations => New_List (
1006 New_Occurrence_Of (Cparm, Clc),
1007 Make_Explicit_Dereference (Loc,
1008 Make_Function_Call (Loc,
1009 Name => Make_Explicit_Dereference (Loc,
1011 (RTE (RE_Get_Current_Excep), Loc))))));
1013 Mark_Rewrite_Insertion (Save);
1014 Prepend (Save, Statements (Handler));
1017 Make_Object_Declaration
1019 Defining_Identifier => Cparm,
1020 Object_Definition =>
1022 (RTE (RE_Exception_Occurrence), Clc));
1023 Set_No_Initialization (Obj_Decl, True);
1026 Make_Implicit_Exception_Handler (Loc,
1027 Exception_Choices => Exception_Choices (Handler),
1029 Statements => New_List (
1030 Make_Block_Statement (Loc,
1031 Declarations => New_List (Obj_Decl),
1032 Handled_Statement_Sequence =>
1033 Make_Handled_Sequence_Of_Statements (Loc,
1034 Statements => Statements (Handler))))));
1036 Analyze_List (Statements (Handler), Suppress => All_Checks);
1040 -- The processing at this point is rather different for the JVM
1041 -- case, so we completely separate the processing.
1043 -- For the JVM case, we unconditionally call Update_Exception,
1044 -- passing a call to the intrinsic Current_Target_Exception (see
1045 -- JVM version of Ada.Exceptions in 4jexcept.adb for details).
1047 if VM_Target /= No_VM then
1049 Arg : constant Node_Id :=
1050 Make_Function_Call (Loc,
1053 (RTE (RE_Current_Target_Exception), Loc));
1055 Prepend_Call_To_Handler
1056 (RE_Update_Exception, New_List (Arg));
1059 -- For the normal case, we have to worry about the state of
1060 -- abort deferral. Generally, we defer abort during runtime
1061 -- handling of exceptions. When control is passed to the
1062 -- handler, then in the normal case we undefer aborts. In any
1063 -- case this entire handling is relevant only if aborts are
1066 elsif Abort_Allowed then
1068 -- There are some special cases in which we do not do the
1069 -- undefer. In particular a finalization (AT END) handler
1070 -- wants to operate with aborts still deferred.
1072 -- We also suppress the call if this is the special handler
1073 -- for Abort_Signal, since if we are aborting, we want to keep
1074 -- aborts deferred (one abort is enough).
1076 -- If abort really needs to be deferred the expander must add
1077 -- this call explicitly, see Expand_N_Asynchronous_Select.
1080 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
1083 or else Entity (First (Exception_Choices (Handler))) /=
1087 and then All_Others (First (Exception_Choices (Handler))))
1088 and then Abort_Allowed
1090 Prepend_Call_To_Handler (RE_Abort_Undefer);
1095 Handler := Next_Handler;
1096 end loop Handler_Loop;
1098 -- If all handlers got removed, then remove the list. Note we cannot
1099 -- reference HSS here, since expanding local handlers may have buried
1100 -- the handlers in an inner block.
1102 if Is_Empty_List (Handlrs) then
1103 Set_Exception_Handlers (Parent (Handlrs), No_List);
1105 end Expand_Exception_Handlers;
1107 ------------------------------------
1108 -- Expand_N_Exception_Declaration --
1109 ------------------------------------
1112 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1113 -- except : exception_data := (
1114 -- Handled_By_Other => False,
1116 -- Name_Length => exceptE'Length,
1117 -- Full_Name => exceptE'Address,
1118 -- HTable_Ptr => null,
1119 -- Import_Code => 0,
1120 -- Raise_Hook => null,
1123 -- (protecting test only needed if not at library level)
1125 -- exceptF : Boolean := True -- static data
1127 -- exceptF := False;
1128 -- Register_Exception (except'Unchecked_Access);
1131 procedure Expand_N_Exception_Declaration (N : Node_Id) is
1132 Loc : constant Source_Ptr := Sloc (N);
1133 Id : constant Entity_Id := Defining_Identifier (N);
1134 L : List_Id := New_List;
1135 Flag_Id : Entity_Id;
1137 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1138 Exname : constant Node_Id :=
1139 Make_Defining_Identifier (Loc, Name_Exname);
1142 -- There is no expansion needed when compiling for the JVM since the
1143 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
1145 if VM_Target /= No_VM then
1149 -- Definition of the external name: nam : constant String := "A.B.NAME";
1152 Make_Object_Declaration (Loc,
1153 Defining_Identifier => Exname,
1154 Constant_Present => True,
1155 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1156 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
1158 Set_Is_Statically_Allocated (Exname);
1160 -- Create the aggregate list for type Standard.Exception_Type:
1161 -- Handled_By_Other component: False
1163 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1165 -- Lang component: 'A'
1168 Make_Character_Literal (Loc,
1170 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
1172 -- Name_Length component: Nam'Length
1175 Make_Attribute_Reference (Loc,
1176 Prefix => New_Occurrence_Of (Exname, Loc),
1177 Attribute_Name => Name_Length));
1179 -- Full_Name component: Standard.A_Char!(Nam'Address)
1181 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1182 Make_Attribute_Reference (Loc,
1183 Prefix => New_Occurrence_Of (Exname, Loc),
1184 Attribute_Name => Name_Address)));
1186 -- HTable_Ptr component: null
1188 Append_To (L, Make_Null (Loc));
1190 -- Import_Code component: 0
1192 Append_To (L, Make_Integer_Literal (Loc, 0));
1194 -- Raise_Hook component: null
1196 Append_To (L, Make_Null (Loc));
1198 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1199 Analyze_And_Resolve (Expression (N), Etype (Id));
1201 -- Register_Exception (except'Unchecked_Access);
1203 if not No_Exception_Handlers_Set
1204 and then not Restriction_Active (No_Exception_Registration)
1207 Make_Procedure_Call_Statement (Loc,
1208 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1209 Parameter_Associations => New_List (
1210 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1211 Make_Attribute_Reference (Loc,
1212 Prefix => New_Occurrence_Of (Id, Loc),
1213 Attribute_Name => Name_Unrestricted_Access)))));
1215 Set_Register_Exception_Call (Id, First (L));
1217 if not Is_Library_Level_Entity (Id) then
1218 Flag_Id := Make_Defining_Identifier (Loc,
1219 New_External_Name (Chars (Id), 'F'));
1222 Make_Object_Declaration (Loc,
1223 Defining_Identifier => Flag_Id,
1224 Object_Definition =>
1225 New_Occurrence_Of (Standard_Boolean, Loc),
1227 New_Occurrence_Of (Standard_True, Loc)));
1229 Set_Is_Statically_Allocated (Flag_Id);
1232 Make_Assignment_Statement (Loc,
1233 Name => New_Occurrence_Of (Flag_Id, Loc),
1234 Expression => New_Occurrence_Of (Standard_False, Loc)));
1236 Insert_After_And_Analyze (N,
1237 Make_Implicit_If_Statement (N,
1238 Condition => New_Occurrence_Of (Flag_Id, Loc),
1239 Then_Statements => L));
1242 Insert_List_After_And_Analyze (N, L);
1246 end Expand_N_Exception_Declaration;
1248 ---------------------------------------------
1249 -- Expand_N_Handled_Sequence_Of_Statements --
1250 ---------------------------------------------
1252 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1254 -- Expand exception handlers
1256 if Present (Exception_Handlers (N))
1257 and then not Restriction_Active (No_Exception_Handlers)
1259 Expand_Exception_Handlers (N);
1262 -- If local exceptions are being expanded, the previous call will
1263 -- have rewritten the construct as a block and reanalyzed it. No
1264 -- further expansion is needed.
1266 if Analyzed (N) then
1270 -- Add clean up actions if required
1272 if Nkind (Parent (N)) /= N_Package_Body
1273 and then Nkind (Parent (N)) /= N_Accept_Statement
1274 and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1275 and then not Delay_Cleanups (Current_Scope)
1277 Expand_Cleanup_Actions (Parent (N));
1279 Set_First_Real_Statement (N, First (Statements (N)));
1281 end Expand_N_Handled_Sequence_Of_Statements;
1283 -------------------------------------
1284 -- Expand_N_Raise_Constraint_Error --
1285 -------------------------------------
1287 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1289 -- We adjust the condition to deal with the C/Fortran boolean case. This
1290 -- may well not be necessary, as all such conditions are generated by
1291 -- the expander and probably are all standard boolean, but who knows
1292 -- what strange optimization in future may require this adjustment!
1294 Adjust_Condition (Condition (N));
1296 -- Now deal with possible local raise handling
1298 Possible_Local_Raise (N, Standard_Constraint_Error);
1299 end Expand_N_Raise_Constraint_Error;
1301 ----------------------------------
1302 -- Expand_N_Raise_Program_Error --
1303 ----------------------------------
1305 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1307 -- We adjust the condition to deal with the C/Fortran boolean case. This
1308 -- may well not be necessary, as all such conditions are generated by
1309 -- the expander and probably are all standard boolean, but who knows
1310 -- what strange optimization in future may require this adjustment!
1312 Adjust_Condition (Condition (N));
1314 -- Now deal with possible local raise handling
1316 Possible_Local_Raise (N, Standard_Program_Error);
1317 end Expand_N_Raise_Program_Error;
1319 ------------------------------
1320 -- Expand_N_Raise_Statement --
1321 ------------------------------
1323 procedure Expand_N_Raise_Statement (N : Node_Id) is
1324 Loc : constant Source_Ptr := Sloc (N);
1331 -- Debug_Flag_Dot_G := True;
1333 -- Processing for locally handled exception (exclude reraise case)
1335 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1337 or else Restriction_Active (No_Exception_Propagation)
1339 -- If we have a local handler, then note that this is potentially
1340 -- able to be transformed into a goto statement.
1342 H := Find_Local_Handler (Entity (Name (N)), N);
1345 if Local_Raise_Statements (H) = No_Elist then
1346 Set_Local_Raise_Statements (H, New_Elmt_List);
1349 -- Append the new entry if it is not there already. Sometimes
1350 -- we have situations where due to reexpansion, the same node
1351 -- is analyzed twice and would otherwise be added twice.
1353 Append_Unique_Elmt (N, Local_Raise_Statements (H));
1354 Set_Has_Local_Raise (H);
1356 -- If no local handler, then generate no propagation warning
1359 Warn_If_No_Propagation (N);
1365 -- If a string expression is present, then the raise statement is
1366 -- converted to a call:
1368 -- Raise_Exception (exception-name'Identity, string);
1370 -- and there is nothing else to do
1372 if Present (Expression (N)) then
1374 Make_Procedure_Call_Statement (Loc,
1375 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1376 Parameter_Associations => New_List (
1377 Make_Attribute_Reference (Loc,
1379 Attribute_Name => Name_Identity),
1385 -- Remaining processing is for the case where no string expression
1388 -- There is no expansion needed for statement "raise <exception>;" when
1389 -- compiling for the JVM since the JVM has a built-in exception
1390 -- mechanism. However we need to keep the expansion for "raise;"
1391 -- statements. See 4jexcept.ads for details.
1393 if Present (Name (N)) and then VM_Target /= No_VM then
1397 -- Don't expand a raise statement that does not come from source
1398 -- if we have already had configurable run-time violations, since
1399 -- most likely it will be junk cascaded nonsense.
1401 if Configurable_Run_Time_Violations > 0
1402 and then not Comes_From_Source (N)
1407 -- Convert explicit raise of Program_Error, Constraint_Error, and
1408 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1409 -- all other raises will get normal expansion and be disallowed,
1410 -- but this is also faster in all modes).
1412 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1413 if Entity (Name (N)) = Standard_Constraint_Error then
1415 Make_Raise_Constraint_Error (Loc,
1416 Reason => CE_Explicit_Raise));
1420 elsif Entity (Name (N)) = Standard_Program_Error then
1422 Make_Raise_Program_Error (Loc,
1423 Reason => PE_Explicit_Raise));
1427 elsif Entity (Name (N)) = Standard_Storage_Error then
1429 Make_Raise_Storage_Error (Loc,
1430 Reason => SE_Explicit_Raise));
1436 -- Case of name present, in this case we expand raise name to
1438 -- Raise_Exception (name'Identity, location_string);
1440 -- where location_string identifies the file/line of the raise
1442 if Present (Name (N)) then
1444 Id : Entity_Id := Entity (Name (N));
1447 Build_Location_String (Loc);
1449 -- If the exception is a renaming, use the exception that it
1450 -- renames (which might be a predefined exception, e.g.).
1452 if Present (Renamed_Object (Id)) then
1453 Id := Renamed_Object (Id);
1456 -- Build a C-compatible string in case of no exception handlers,
1457 -- since this is what the last chance handler is expecting.
1459 if No_Exception_Handlers_Set then
1461 -- Generate an empty message if configuration pragma
1462 -- Suppress_Exception_Locations is set for this unit.
1464 if Opt.Exception_Locations_Suppressed then
1467 Name_Len := Name_Len + 1;
1470 Name_Buffer (Name_Len) := ASCII.NUL;
1473 if Opt.Exception_Locations_Suppressed then
1477 Str := String_From_Name_Buffer;
1479 -- For VMS exceptions, convert the raise into a call to
1480 -- lib$stop so it will be handled by __gnat_error_handler.
1482 if Is_VMS_Exception (Id) then
1484 Excep_Image : String_Id;
1488 if Present (Interface_Name (Id)) then
1489 Excep_Image := Strval (Interface_Name (Id));
1491 Get_Name_String (Chars (Id));
1493 Excep_Image := String_From_Name_Buffer;
1496 if Exception_Code (Id) /= No_Uint then
1498 Make_Integer_Literal (Loc, Exception_Code (Id));
1501 Unchecked_Convert_To (Standard_Integer,
1502 Make_Function_Call (Loc,
1503 Name => New_Occurrence_Of
1504 (RTE (RE_Import_Value), Loc),
1505 Parameter_Associations => New_List
1506 (Make_String_Literal (Loc,
1507 Strval => Excep_Image))));
1511 Make_Procedure_Call_Statement (Loc,
1513 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1514 Parameter_Associations => New_List (Cond)));
1515 Analyze_And_Resolve (Cond, Standard_Integer);
1518 -- Not VMS exception case, convert raise to call to the
1519 -- Raise_Exception routine.
1523 Make_Procedure_Call_Statement (Loc,
1524 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1525 Parameter_Associations => New_List (
1526 Make_Attribute_Reference (Loc,
1528 Attribute_Name => Name_Identity),
1529 Make_String_Literal (Loc,
1534 -- Case of no name present (reraise). We rewrite the raise to:
1536 -- Reraise_Occurrence_Always (EO);
1538 -- where EO is the current exception occurrence. If the current handler
1539 -- does not have a choice parameter specification, then we provide one.
1542 -- Find innermost enclosing exception handler (there must be one,
1543 -- since the semantics has already verified that this raise statement
1544 -- is valid, and a raise with no arguments is only permitted in the
1545 -- context of an exception handler.
1547 Ehand := Parent (N);
1548 while Nkind (Ehand) /= N_Exception_Handler loop
1549 Ehand := Parent (Ehand);
1552 -- Make exception choice parameter if none present. Note that we do
1553 -- not need to put the entity on the entity chain, since no one will
1554 -- be referencing this entity by normal visibility methods.
1556 if No (Choice_Parameter (Ehand)) then
1557 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1558 Set_Choice_Parameter (Ehand, E);
1559 Set_Ekind (E, E_Variable);
1560 Set_Etype (E, RTE (RE_Exception_Occurrence));
1561 Set_Scope (E, Current_Scope);
1564 -- Now rewrite the raise as a call to Reraise. A special case arises
1565 -- if this raise statement occurs in the context of a handler for
1566 -- all others (i.e. an at end handler). in this case we avoid
1567 -- the call to defer abort, cleanup routines are expected to be
1568 -- called in this case with aborts deferred.
1571 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1575 if Nkind (Ech) = N_Others_Choice
1576 and then All_Others (Ech)
1578 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1580 Ent := RTE (RE_Reraise_Occurrence_Always);
1584 Make_Procedure_Call_Statement (Loc,
1585 Name => New_Occurrence_Of (Ent, Loc),
1586 Parameter_Associations => New_List (
1587 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1592 end Expand_N_Raise_Statement;
1594 ----------------------------------
1595 -- Expand_N_Raise_Storage_Error --
1596 ----------------------------------
1598 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1600 -- We adjust the condition to deal with the C/Fortran boolean case. This
1601 -- may well not be necessary, as all such conditions are generated by
1602 -- the expander and probably are all standard boolean, but who knows
1603 -- what strange optimization in future may require this adjustment!
1605 Adjust_Condition (Condition (N));
1607 -- Now deal with possible local raise handling
1609 Possible_Local_Raise (N, Standard_Storage_Error);
1610 end Expand_N_Raise_Storage_Error;
1612 --------------------------
1613 -- Possible_Local_Raise --
1614 --------------------------
1616 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1618 -- Nothing to do if local raise optimization not active
1620 if not Debug_Flag_Dot_G
1621 and then not Restriction_Active (No_Exception_Propagation)
1626 -- Nothing to do if original node was an explicit raise, because in
1627 -- that case, we already generated the required warning for the raise.
1629 if Nkind (Original_Node (N)) = N_Raise_Statement then
1633 -- Otherwise see if we have a local handler for the exception
1636 H : constant Node_Id := Find_Local_Handler (E, N);
1639 -- If so, mark that it has a local raise
1642 Set_Has_Local_Raise (H, True);
1644 -- Otherwise, if the No_Exception_Propagation restriction is active
1645 -- and the warning is enabled, generate the appropriate warnings.
1647 elsif Warn_On_Non_Local_Exception
1648 and then Restriction_Active (No_Exception_Propagation)
1650 Warn_No_Exception_Propagation_Active (N);
1652 if Configurable_Run_Time_Mode then
1654 ("\?& may call Last_Chance_Handler", N, E);
1657 ("\?& may result in unhandled exception", N, E);
1661 end Possible_Local_Raise;
1663 ------------------------------
1664 -- Expand_N_Subprogram_Info --
1665 ------------------------------
1667 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1668 Loc : constant Source_Ptr := Sloc (N);
1671 -- For now, we replace an Expand_N_Subprogram_Info node with an
1672 -- attribute reference that gives the address of the procedure.
1673 -- This is because gigi does not yet recognize this node, and
1674 -- for the initial targets, this is the right value anyway.
1677 Make_Attribute_Reference (Loc,
1678 Prefix => Identifier (N),
1679 Attribute_Name => Name_Code_Address));
1681 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1682 end Expand_N_Subprogram_Info;
1684 ------------------------
1685 -- Find_Local_Handler --
1686 ------------------------
1688 function Find_Local_Handler
1690 Nod : Node_Id) return Node_Id
1697 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1698 -- This is used to test for wrapped actions below
1701 EHandle : Entity_Id;
1702 -- The entity Id's for the exception we are raising and handling, using
1703 -- the renamed exception if a Renamed_Entity is present.
1706 -- Never any local handler if all handlers removed
1708 if Debug_Flag_Dot_X then
1712 -- Get the exception we are raising, allowing for renaming
1714 ERaise := Get_Renamed_Entity (Ename);
1716 -- We need to check if the node we are looking at is contained in
1719 -- Loop to search up the tree
1725 -- If we get to the top of the tree, or to a subprogram, task, entry,
1726 -- protected body, or accept statement without having found a
1727 -- matching handler, then there is no local handler.
1730 or else Nkind (P) = N_Subprogram_Body
1731 or else Nkind (P) = N_Task_Body
1732 or else Nkind (P) = N_Protected_Body
1733 or else Nkind (P) = N_Entry_Body
1734 or else Nkind (P) = N_Accept_Statement
1738 -- Test for handled sequence of statements with at least one
1739 -- exception handler which might be the one we are looking for.
1741 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1742 and then Present (Exception_Handlers (P))
1744 -- Before we proceed we need to check if the node N is covered
1745 -- by the statement part of P rather than one of its exception
1746 -- handlers (an exception handler obviously does not cover its
1749 -- This test is more delicate than might be thought. It is not
1750 -- just a matter of checking the Statements (P), because the node
1751 -- might be waiting to be wrapped in a transient scope, in which
1752 -- case it will end up in the block statements, even though it
1753 -- is not there now.
1755 if Is_List_Member (N)
1756 and then (List_Containing (N) = Statements (P)
1758 List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
1760 List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
1762 -- Loop through exception handlers
1764 H := First (Exception_Handlers (P));
1765 while Present (H) loop
1767 -- Loop through choices in one handler
1769 C := First (Exception_Choices (H));
1770 while Present (C) loop
1772 -- Deal with others case
1774 if Nkind (C) = N_Others_Choice then
1776 -- Matching others handler, but we need to ensure
1777 -- there is no choice parameter. If there is, then we
1778 -- don't have a local handler after all (since we do
1779 -- not allow choice parameters for local handlers).
1781 if No (Choice_Parameter (H)) then
1787 -- If not others must be entity name
1789 elsif Nkind (C) /= N_Others_Choice then
1790 pragma Assert (Is_Entity_Name (C));
1791 pragma Assert (Present (Entity (C)));
1793 -- Get exception being handled, dealing with renaming
1795 EHandle := Get_Renamed_Entity (Entity (C));
1797 -- If match, then check choice parameter
1799 if ERaise = EHandle then
1800 if No (Choice_Parameter (H)) then
1818 end Find_Local_Handler;
1820 ---------------------------------
1821 -- Get_Local_Raise_Call_Entity --
1822 ---------------------------------
1824 -- Note: this is primary provided for use by the back end in generating
1825 -- calls to Local_Raise. But it would be too late in the back end to call
1826 -- RTE if this actually caused a load/analyze of the unit. So what we do
1827 -- is to ensure there is a dummy call to this function during front end
1828 -- processing so that the unit gets loaded then, and not later.
1830 Local_Raise_Call_Entity : Entity_Id;
1831 Local_Raise_Call_Entity_Set : Boolean := False;
1833 function Get_Local_Raise_Call_Entity return Entity_Id is
1835 if not Local_Raise_Call_Entity_Set then
1836 Local_Raise_Call_Entity_Set := True;
1838 if RTE_Available (RE_Local_Raise) then
1839 Local_Raise_Call_Entity := RTE (RE_Local_Raise);
1841 Local_Raise_Call_Entity := Empty;
1845 return Local_Raise_Call_Entity;
1846 end Get_Local_Raise_Call_Entity;
1848 -----------------------------
1849 -- Get_RT_Exception_Entity --
1850 -----------------------------
1852 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
1855 when RT_CE_Exceptions => return Standard_Constraint_Error;
1856 when RT_PE_Exceptions => return Standard_Program_Error;
1857 when RT_SE_Exceptions => return Standard_Storage_Error;
1859 end Get_RT_Exception_Entity;
1861 ----------------------
1862 -- Is_Non_Ada_Error --
1863 ----------------------
1865 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1867 if not OpenVMS_On_Target then
1871 Get_Name_String (Chars (E));
1873 -- Note: it is a little irregular for the body of exp_ch11 to know
1874 -- the details of the encoding scheme for names, but on the other
1875 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1877 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1882 end Is_Non_Ada_Error;
1884 ----------------------------
1885 -- Warn_If_No_Propagation --
1886 ----------------------------
1888 procedure Warn_If_No_Propagation (N : Node_Id) is
1890 if Restriction_Active (No_Exception_Propagation)
1891 and then Warn_On_Non_Local_Exception
1893 Warn_No_Exception_Propagation_Active (N);
1895 if Configurable_Run_Time_Mode then
1897 ("\?Last_Chance_Handler will be called on exception", N);
1900 ("\?execution may raise unhandled exception", N);
1903 end Warn_If_No_Propagation;
1905 ------------------------------------------
1906 -- Warn_No_Exception_Propagation_Active --
1907 ------------------------------------------
1909 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
1912 ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
1913 end Warn_No_Exception_Propagation_Active;