1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Ch7
; use Exp_Ch7
;
33 with Exp_Util
; use Exp_Util
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Restrict
; use Restrict
;
39 with Rident
; use Rident
;
40 with Rtsfind
; use Rtsfind
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Sinput
; use Sinput
;
47 with Snames
; use Snames
;
48 with Stand
; use Stand
;
49 with Stringt
; use Stringt
;
50 with Targparm
; use Targparm
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
54 package body Exp_Ch11
is
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
60 procedure Warn_No_Exception_Propagation_Active
(N
: Node_Id
);
61 -- Generates warning that pragma Restrictions (No_Exception_Propagation)
62 -- is in effect. Caller then generates appropriate continuation message.
63 -- N is the node on which the warning is placed.
65 procedure Warn_If_No_Propagation
(N
: Node_Id
);
66 -- Called for an exception raise that is not a local raise (and thus can
67 -- not be optimized to a goto. Issues warning if No_Exception_Propagation
68 -- restriction is set. N is the node for the raise or equivalent call.
70 ---------------------------
71 -- Expand_At_End_Handler --
72 ---------------------------
74 -- For a handled statement sequence that has a cleanup (At_End_Proc
75 -- field set), an exception handler of the following form is required:
82 -- Note: this exception handler is treated rather specially by
83 -- subsequent expansion in two respects:
85 -- The normal call to Undefer_Abort is omitted
86 -- The raise call does not do Defer_Abort
88 -- This is because the current tasking code seems to assume that
89 -- the call to the cleanup routine that is made from an exception
90 -- handler for the abort signal is called with aborts deferred.
92 -- This expansion is only done if we have front end exception handling.
93 -- If we have back end exception handling, then the AT END handler is
94 -- left alone, and cleanups (including the exceptional case) are handled
97 -- In the front end case, the exception handler described above handles
98 -- the exceptional case. The AT END handler is left in the generated tree
99 -- and the code generator (e.g. gigi) must still handle proper generation
100 -- of cleanup calls for the non-exceptional case.
102 procedure Expand_At_End_Handler
(HSS
: Node_Id
; Block
: Node_Id
) is
103 Clean
: constant Entity_Id
:= Entity
(At_End_Proc
(HSS
));
104 Loc
: constant Source_Ptr
:= Sloc
(Clean
);
109 pragma Assert
(Present
(Clean
));
110 pragma Assert
(No
(Exception_Handlers
(HSS
)));
112 -- Don't expand if back end exception handling active
114 if Exception_Mechanism
= Back_End_Exceptions
then
118 -- Don't expand an At End handler if we have already had configurable
119 -- run-time violations, since likely this will just be a matter of
120 -- generating useless cascaded messages
122 if Configurable_Run_Time_Violations
> 0 then
126 -- Don't expand an At End handler if we are not allowing exceptions
127 -- or if exceptions are transformed into local gotos, and never
128 -- propagated (No_Exception_Propagation).
130 if No_Exception_Handlers_Set
then
134 if Present
(Block
) then
139 Make_Others_Choice
(Loc
);
140 Set_All_Others
(Ohandle
);
143 Make_Procedure_Call_Statement
(Loc
,
144 Name
=> New_Occurrence_Of
(Clean
, Loc
)));
146 -- Generate reraise statement as last statement of AT-END handler,
147 -- unless we are under control of No_Exception_Propagation, in which
148 -- case no exception propagation is possible anyway, so we do not need
149 -- a reraise (the AT END handler in this case is only for normal exits
150 -- not for exceptional exits). Also, we flag the Reraise statement as
151 -- being part of an AT END handler to prevent signalling this reraise
152 -- as a violation of the restriction when it is not set.
154 if not Restriction_Active
(No_Exception_Propagation
) then
156 Rstm
: constant Node_Id
:= Make_Raise_Statement
(Loc
);
158 Set_From_At_End
(Rstm
);
159 Append_To
(Stmnts
, Rstm
);
163 Set_Exception_Handlers
(HSS
, New_List
(
164 Make_Implicit_Exception_Handler
(Loc
,
165 Exception_Choices
=> New_List
(Ohandle
),
166 Statements
=> Stmnts
)));
168 Analyze_List
(Stmnts
, Suppress
=> All_Checks
);
169 Expand_Exception_Handlers
(HSS
);
171 if Present
(Block
) then
174 end Expand_At_End_Handler
;
176 -------------------------------
177 -- Expand_Exception_Handlers --
178 -------------------------------
180 procedure Expand_Exception_Handlers
(HSS
: Node_Id
) is
181 Handlrs
: constant List_Id
:= Exception_Handlers
(HSS
);
182 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
184 Others_Choice
: Boolean;
186 Next_Handler
: Node_Id
;
188 procedure Expand_Local_Exception_Handlers
;
189 -- This procedure handles the expansion of exception handlers for the
190 -- optimization of local raise statements into goto statements.
192 procedure Prepend_Call_To_Handler
194 Args
: List_Id
:= No_List
);
195 -- Routine to prepend a call to the procedure referenced by Proc at
196 -- the start of the handler code for the current Handler.
198 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
);
199 -- Raise_S is a raise statement (possibly expanded, and possibly of the
200 -- form of a Raise_xxx_Error node with a condition. This procedure is
201 -- called to replace the raise action with the (already analyzed) goto
202 -- statement passed as Goto_L1. This procedure also takes care of the
203 -- requirement of inserting a Local_Raise call where possible.
205 -------------------------------------
206 -- Expand_Local_Exception_Handlers --
207 -------------------------------------
209 -- There are two cases for this transformation. First the case of
210 -- explicit raise statements. For this case, the transformation we do
211 -- looks like this. Right now we have for example (where L1, L2 are
216 -- raise_exception (excep1'identity); -- was raise excep1
218 -- raise_exception (excep2'identity); -- was raise excep2
227 -- This gets transformed into:
230 -- L1 : label; -- marked Exception_Junk
231 -- L2 : label; -- marked Exception_Junk
232 -- L3 : label; -- marked Exception_Junk
234 -- begin -- marked Exception_Junk
236 -- local_raise (excep1'address); -- was raise excep1
239 -- local_raise (excep2'address); -- was raise excep2
249 -- goto L3; -- skip handler if no raise, marked Exception_Junk
251 -- <<L1>> -- local excep target label, marked Exception_Junk
252 -- begin -- marked Exception_Junk
255 -- goto L3; -- marked Exception_Junk
257 -- <<L2>> -- marked Exception_Junk
258 -- begin -- marked Exception_Junk
261 -- goto L3; -- marked Exception_Junk
262 -- <<L3>> -- marked Exception_Junk
265 -- Note: the reason we wrap the original statement sequence in an
266 -- inner block is that there may be raise statements within the
267 -- sequence of statements in the handlers, and we must ensure that
268 -- these are properly handled, and in particular, such raise statements
269 -- must not reenter the same exception handlers.
271 -- If the restriction No_Exception_Propagation is in effect, then we
272 -- can omit the exception handlers.
275 -- L1 : label; -- marked Exception_Junk
276 -- L2 : label; -- marked Exception_Junk
277 -- L3 : label; -- marked Exception_Junk
279 -- begin -- marked Exception_Junk
281 -- local_raise (excep1'address); -- was raise excep1
284 -- local_raise (excep2'address); -- was raise excep2
289 -- goto L3; -- skip handler if no raise, marked Exception_Junk
291 -- <<L1>> -- local excep target label, marked Exception_Junk
292 -- begin -- marked Exception_Junk
295 -- goto L3; -- marked Exception_Junk
297 -- <<L2>> -- marked Exception_Junk
298 -- begin -- marked Exception_Junk
302 -- <<L3>> -- marked Exception_Junk
305 -- The second case is for exceptions generated by the back end in one
306 -- of three situations:
308 -- 1. Front end generates N_Raise_xxx_Error node
309 -- 2. Front end sets Do_xxx_Check flag in subexpression node
310 -- 3. Back end detects a situation where an exception is appropriate
312 -- In all these cases, the current processing in gigi is to generate a
313 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
314 -- exception message and the exception to be raised, Constraint_Error,
315 -- Program_Error, or Storage_Error.
317 -- We could handle some subcases of 1 using the same front end expansion
318 -- into gotos, but even for case 1, we can't handle all cases, since
319 -- generating gotos in the middle of expressions is not possible (it's
320 -- possible at the gigi/gcc level, but not at the level of the GNAT
323 -- In any case, it seems easier to have a scheme which handles all three
324 -- cases in a uniform manner. So here is how we proceed in this case.
326 -- This procedure detects all handlers for these three exceptions,
327 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
328 -- OTHERS handlers that cover one or more of these cases).
330 -- If the handler meets the requirements for being the target of a local
331 -- raise, then the front end does the expansion described previously,
332 -- creating a label to be used as a goto target to raise the exception.
333 -- However, no attempt is made in the front end to convert any related
334 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
335 -- left unchanged and passed to the back end.
337 -- Instead, the front end generates two nodes
339 -- N_Push_Constraint_Error_Label
340 -- N_Push_Program_Error_Label
341 -- N_Push_Storage_Error_Label
343 -- The Push node is generated at the start of the statements
344 -- covered by the handler, and has as a parameter the label to be
345 -- used as the raise target.
347 -- N_Pop_Constraint_Error_Label
348 -- N_Pop_Program_Error_Label
349 -- N_Pop_Storage_Error_Label
351 -- The Pop node is generated at the end of the covered statements
352 -- and undoes the effect of the preceding corresponding Push node.
354 -- In the case where the handler does NOT meet the requirements, the
355 -- front end will still generate the Push and Pop nodes, but the label
356 -- field in the Push node will be empty signifying that for this region
357 -- of code, no optimization is possible.
359 -- The back end must maintain three stacks, one for each exception case,
360 -- the Push node pushes an entry onto the corresponding stack, and Pop
361 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
362 -- corresponding top stack entry has an non-empty label, a goto is
363 -- generated. This goto should be preceded by a call to Local_Raise as
366 -- An example of this transformation is as follows, given:
369 -- A : Integer range 1 .. 10;
373 -- when Constraint_Error =>
377 -- gets transformed to:
380 -- A : Integer range 1 .. 10;
387 -- %push_constraint_error_label (L1)
388 -- R1b : constant long_long_integer := long_long_integer?(b) +
389 -- long_long_integer?(c);
390 -- [constraint_error when
391 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
392 -- "overflow check failed"]
393 -- a := integer?(R1b);
394 -- %pop_constraint_error_Label
398 -- when constraint_error =>
402 -- goto L2; -- skip handler when exception not raised
403 -- <<L1>> -- target label for local exception
408 -- Note: the generated labels and goto statements all have the flag
409 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
410 -- this generated exception stuff when checking for missing return
411 -- statements (see circuitry in Check_Statement_Sequence).
413 -- Note: All of the processing described above occurs only if
414 -- restriction No_Exception_Propagation applies or debug flag .g is
417 CE_Locally_Handled
: Boolean := False;
418 SE_Locally_Handled
: Boolean := False;
419 PE_Locally_Handled
: Boolean := False;
420 -- These three flags indicate whether a handler for the corresponding
421 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
422 -- is present. If so the switch is set to True, the Exception_Label
423 -- field of the corresponding handler is set, and appropriate Push
424 -- and Pop nodes are inserted into the code.
426 Local_Expansion_Required
: Boolean := False;
427 -- Set True if we have at least one handler requiring local raise
428 -- expansion as described above.
430 procedure Expand_Local_Exception_Handlers
is
432 procedure Add_Exception_Label
(H
: Node_Id
);
433 -- H is an exception handler. First check for an Exception_Label
434 -- already allocated for H. If none, allocate one, set the field in
435 -- the handler node, add the label declaration, and set the flag
436 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
437 -- the call has no effect and Exception_Label is left empty.
439 procedure Add_Label_Declaration
(L
: Entity_Id
);
440 -- Add an implicit declaration of the given label to the declaration
441 -- list in the parent of the current sequence of handled statements.
444 Exc_Locally_Handled
: in out Boolean;
445 -- Flag indicating whether a local handler for this exception
446 -- has already been generated.
448 with function Make_Push_Label
(Loc
: Source_Ptr
) return Node_Id
;
449 -- Function to create a Push_xxx_Label node
451 with function Make_Pop_Label
(Loc
: Source_Ptr
) return Node_Id
;
452 -- Function to create a Pop_xxx_Label node
454 procedure Generate_Push_Pop
(H
: Node_Id
);
455 -- Common code for Generate_Push_Pop_xxx below, used to generate an
456 -- exception label and Push/Pop nodes for Constraint_Error,
457 -- Program_Error, or Storage_Error.
459 -------------------------
460 -- Add_Exception_Label --
461 -------------------------
463 procedure Add_Exception_Label
(H
: Node_Id
) is
465 if No
(Exception_Label
(H
))
466 and then not Local_Raise_Not_OK
(H
)
467 and then not Special_Exception_Package_Used
469 Local_Expansion_Required
:= True;
472 L
: constant Entity_Id
:=
473 Make_Defining_Identifier
(Sloc
(H
),
474 Chars
=> New_Internal_Name
('L'));
476 Set_Exception_Label
(H
, L
);
477 Add_Label_Declaration
(L
);
480 end Add_Exception_Label
;
482 ---------------------------
483 -- Add_Label_Declaration --
484 ---------------------------
486 procedure Add_Label_Declaration
(L
: Entity_Id
) is
487 P
: constant Node_Id
:= Parent
(HSS
);
489 Decl_L
: constant Node_Id
:=
490 Make_Implicit_Label_Declaration
(Loc
,
491 Defining_Identifier
=> L
);
494 if Declarations
(P
) = No_List
then
495 Set_Declarations
(P
, Empty_List
);
498 Append
(Decl_L
, Declarations
(P
));
500 end Add_Label_Declaration
;
502 -----------------------
503 -- Generate_Push_Pop --
504 -----------------------
506 procedure Generate_Push_Pop
(H
: Node_Id
) is
508 if Exc_Locally_Handled
then
511 Exc_Locally_Handled
:= True;
514 Add_Exception_Label
(H
);
517 F
: constant Node_Id
:= First
(Statements
(HSS
));
518 L
: constant Node_Id
:= Last
(Statements
(HSS
));
520 Push
: constant Node_Id
:= Make_Push_Label
(Sloc
(F
));
521 Pop
: constant Node_Id
:= Make_Pop_Label
(Sloc
(L
));
524 -- We make sure that a call to Get_Local_Raise_Call_Entity is
525 -- made during front end processing, so that when we need it
526 -- in the back end, it will already be available and loaded.
528 Discard_Node
(Get_Local_Raise_Call_Entity
);
530 -- Prepare and insert Push and Pop nodes
532 Set_Exception_Label
(Push
, Exception_Label
(H
));
533 Insert_Before
(F
, Push
);
536 Insert_After
(L
, Pop
);
539 end Generate_Push_Pop
;
541 -- Local declarations
543 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
544 Stmts
: List_Id
:= No_List
;
548 procedure Generate_Push_Pop_For_Constraint_Error
is
549 new Generate_Push_Pop
550 (Exc_Locally_Handled
=> CE_Locally_Handled
,
551 Make_Push_Label
=> Make_Push_Constraint_Error_Label
,
552 Make_Pop_Label
=> Make_Pop_Constraint_Error_Label
);
553 -- If no Push/Pop has been generated for CE yet, then set the flag
554 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
555 -- not already done), and generate Push/Pop nodes for the exception
556 -- label at the start and end of the statements of HSS.
558 procedure Generate_Push_Pop_For_Program_Error
is
559 new Generate_Push_Pop
560 (Exc_Locally_Handled
=> PE_Locally_Handled
,
561 Make_Push_Label
=> Make_Push_Program_Error_Label
,
562 Make_Pop_Label
=> Make_Pop_Program_Error_Label
);
563 -- If no Push/Pop has been generated for PE yet, then set the flag
564 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
565 -- not already done), and generate Push/Pop nodes for the exception
566 -- label at the start and end of the statements of HSS.
568 procedure Generate_Push_Pop_For_Storage_Error
is
569 new Generate_Push_Pop
570 (Exc_Locally_Handled
=> SE_Locally_Handled
,
571 Make_Push_Label
=> Make_Push_Storage_Error_Label
,
572 Make_Pop_Label
=> Make_Pop_Storage_Error_Label
);
573 -- If no Push/Pop has been generated for SE yet, then set the flag
574 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
575 -- not already done), and generate Push/Pop nodes for the exception
576 -- label at the start and end of the statements of HSS.
578 -- Start of processing for Expand_Local_Exception_Handlers
581 -- No processing if all exception handlers will get removed
583 if Debug_Flag_Dot_X
then
587 -- See for each handler if we have any local raises to expand
589 Handler
:= First_Non_Pragma
(Handlrs
);
590 while Present
(Handler
) loop
592 -- Note, we do not test Local_Raise_Not_OK here, because in the
593 -- case of Push/Pop generation we want to generate push with a
594 -- null label. The Add_Exception_Label routine has no effect if
595 -- Local_Raise_Not_OK is set, so this works as required.
597 if Present
(Local_Raise_Statements
(Handler
)) then
598 Add_Exception_Label
(Handler
);
601 -- If we are doing local raise to goto optimization (restriction
602 -- No_Exception_Propagation set or debug flag .g set), then check
603 -- to see if handler handles CE, PE, SE and if so generate the
604 -- appropriate push/pop sequence for the back end.
607 or else Restriction_Active
(No_Exception_Propagation
))
608 and then Has_Local_Raise
(Handler
)
610 Choice
:= First
(Exception_Choices
(Handler
));
611 while Present
(Choice
) loop
612 if Nkind
(Choice
) = N_Others_Choice
613 and then not All_Others
(Choice
)
615 Generate_Push_Pop_For_Constraint_Error
(Handler
);
616 Generate_Push_Pop_For_Program_Error
(Handler
);
617 Generate_Push_Pop_For_Storage_Error
(Handler
);
619 elsif Is_Entity_Name
(Choice
) then
620 Excep
:= Get_Renamed_Entity
(Entity
(Choice
));
622 if Excep
= Standard_Constraint_Error
then
623 Generate_Push_Pop_For_Constraint_Error
(Handler
);
624 elsif Excep
= Standard_Program_Error
then
625 Generate_Push_Pop_For_Program_Error
(Handler
);
626 elsif Excep
= Standard_Storage_Error
then
627 Generate_Push_Pop_For_Storage_Error
(Handler
);
635 Next_Non_Pragma
(Handler
);
638 -- Nothing to do if no handlers requiring the goto transformation
640 if not (Local_Expansion_Required
) then
644 -- Prepare to do the transformation
647 -- L3 is the label to exit the HSS
649 L3_Dent
: constant Entity_Id
:=
650 Make_Defining_Identifier
(Loc
,
651 Chars
=> New_Internal_Name
('L'));
653 Labl_L3
: constant Node_Id
:=
655 Identifier
=> New_Occurrence_Of
(L3_Dent
, Loc
));
661 Set_Exception_Junk
(Labl_L3
);
662 Add_Label_Declaration
(L3_Dent
);
664 -- Wrap existing statements and handlers in an inner block
667 Make_Block_Statement
(Loc
,
668 Handled_Statement_Sequence
=> Relocate_Node
(HSS
));
669 Set_Exception_Junk
(Blk_Stm
);
672 Make_Handled_Sequence_Of_Statements
(Loc
,
673 Statements
=> New_List
(Blk_Stm
)));
675 -- Set block statement as analyzed, we don't want to actually call
676 -- Analyze on this block, it would cause a recursion in exception
677 -- handler processing which would mess things up.
679 Set_Analyzed
(Blk_Stm
);
681 -- Now loop through the exception handlers to deal with those that
682 -- are targets of local raise statements.
684 Handler
:= First_Non_Pragma
(Handlrs
);
685 while Present
(Handler
) loop
686 if Present
(Exception_Label
(Handler
)) then
688 -- This handler needs the goto expansion
691 Loc
: constant Source_Ptr
:= Sloc
(Handler
);
693 -- L1 is the start label for this handler
695 L1_Dent
: constant Entity_Id
:= Exception_Label
(Handler
);
697 Labl_L1
: constant Node_Id
:=
700 New_Occurrence_Of
(L1_Dent
, Loc
));
702 -- Jump to L1 to be used as replacement for the original
703 -- handler (used in the case where exception propagation
706 Name_L1
: constant Node_Id
:=
707 New_Occurrence_Of
(L1_Dent
, Loc
);
709 Goto_L1
: constant Node_Id
:=
710 Make_Goto_Statement
(Loc
,
713 -- Jump to L3 to be used at the end of handler
715 Name_L3
: constant Node_Id
:=
716 New_Occurrence_Of
(L3_Dent
, Loc
);
718 Goto_L3
: constant Node_Id
:=
719 Make_Goto_Statement
(Loc
,
722 H_Stmts
: constant List_Id
:= Statements
(Handler
);
725 Set_Exception_Junk
(Labl_L1
);
726 Set_Exception_Junk
(Goto_L3
);
728 -- Note: we do NOT set Exception_Junk in Goto_L1, since
729 -- this is a real transfer of control that we want the
730 -- Sem_Ch6.Check_Returns procedure to recognize properly.
732 -- Replace handler by a goto L1. We can mark this as
733 -- analyzed since it is fully formed, and we don't
734 -- want it going through any further checks. We save
735 -- the last statement location in the goto L1 node for
736 -- the benefit of Sem_Ch6.Check_Returns.
738 Set_Statements
(Handler
, New_List
(Goto_L1
));
739 Set_Analyzed
(Goto_L1
);
740 Set_Etype
(Name_L1
, Standard_Void_Type
);
742 -- Now replace all the raise statements by goto L1
744 if Present
(Local_Raise_Statements
(Handler
)) then
745 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
746 while Present
(Relmt
) loop
748 Raise_S
: constant Node_Id
:= Node
(Relmt
);
750 Name_L1
: constant Node_Id
:=
751 New_Occurrence_Of
(L1_Dent
, Loc
);
753 Goto_L1
: constant Node_Id
:=
754 Make_Goto_Statement
(Loc
,
758 -- Replace raise by goto L1
760 Set_Analyzed
(Goto_L1
);
761 Set_Etype
(Name_L1
, Standard_Void_Type
);
762 Replace_Raise_By_Goto
(Raise_S
, Goto_L1
);
769 -- Add a goto L3 at end of statement list in block. The
770 -- first time, this is what skips over the exception
771 -- handlers in the normal case. Subsequent times, it
772 -- terminates the execution of the previous handler code,
773 -- and skips subsequent handlers.
775 Stmts
:= Statements
(HSS
);
777 Insert_After
(Last
(Stmts
), Goto_L3
);
778 Set_Analyzed
(Goto_L3
);
779 Set_Etype
(Name_L3
, Standard_Void_Type
);
781 -- Now we drop the label that marks the handler start,
782 -- followed by the statements of the handler.
784 Set_Etype
(Identifier
(Labl_L1
), Standard_Void_Type
);
786 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L1
);
789 Loc
: constant Source_Ptr
:= Sloc
(First
(H_Stmts
));
790 Blk
: constant Node_Id
:=
791 Make_Block_Statement
(Loc
,
792 Handled_Statement_Sequence
=>
793 Make_Handled_Sequence_Of_Statements
(Loc
,
794 Statements
=> H_Stmts
));
796 Set_Exception_Junk
(Blk
);
797 Insert_After_And_Analyze
(Last
(Stmts
), Blk
);
801 -- Here if we have local raise statements but the handler is
802 -- not suitable for processing with a local raise. In this
803 -- case we have to generate possible diagnostics.
805 elsif Has_Local_Raise
(Handler
)
806 and then Local_Raise_Statements
(Handler
) /= No_Elist
808 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
809 while Present
(Relmt
) loop
810 Warn_If_No_Propagation
(Node
(Relmt
));
818 -- Only remaining step is to drop the L3 label and we are done
820 Set_Etype
(Identifier
(Labl_L3
), Standard_Void_Type
);
822 -- If we had at least one handler, then we drop the label after
823 -- the last statement of that handler.
825 if Stmts
/= No_List
then
826 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L3
);
828 -- Otherwise we have removed all the handlers (this results from
829 -- use of pragma Restrictions (No_Exception_Propagation), and we
830 -- drop the label at the end of the statements of the HSS.
833 Insert_After_And_Analyze
(Last
(Statements
(HSS
)), Labl_L3
);
838 end Expand_Local_Exception_Handlers
;
840 -----------------------------
841 -- Prepend_Call_To_Handler --
842 -----------------------------
844 procedure Prepend_Call_To_Handler
846 Args
: List_Id
:= No_List
)
848 Ent
: constant Entity_Id
:= RTE
(Proc
);
851 -- If we have no Entity, then we are probably in no run time mode or
852 -- some weird error has occurred. In either case do nothing. Note use
853 -- of No_Location to hide this code from the debugger, so single
854 -- stepping doesn't jump back and forth.
856 if Present
(Ent
) then
858 Call
: constant Node_Id
:=
859 Make_Procedure_Call_Statement
(No_Location
,
860 Name
=> New_Occurrence_Of
(RTE
(Proc
), No_Location
),
861 Parameter_Associations
=> Args
);
864 Prepend_To
(Statements
(Handler
), Call
);
865 Analyze
(Call
, Suppress
=> All_Checks
);
868 end Prepend_Call_To_Handler
;
870 ---------------------------
871 -- Replace_Raise_By_Goto --
872 ---------------------------
874 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
) is
875 Loc
: constant Source_Ptr
:= Sloc
(Raise_S
);
882 -- If we have a null statement, it means that there is no replacement
883 -- needed (typically this results from a suppressed check).
885 if Nkind
(Raise_S
) = N_Null_Statement
then
888 -- Test for Raise_xxx_Error
890 elsif Nkind
(Raise_S
) = N_Raise_Constraint_Error
then
891 Excep
:= Standard_Constraint_Error
;
892 Cond
:= Condition
(Raise_S
);
894 elsif Nkind
(Raise_S
) = N_Raise_Storage_Error
then
895 Excep
:= Standard_Storage_Error
;
896 Cond
:= Condition
(Raise_S
);
898 elsif Nkind
(Raise_S
) = N_Raise_Program_Error
then
899 Excep
:= Standard_Program_Error
;
900 Cond
:= Condition
(Raise_S
);
902 -- The only other possibility is a node that is or used to be a
903 -- simple raise statement.
906 Orig
:= Original_Node
(Raise_S
);
907 pragma Assert
(Nkind
(Orig
) = N_Raise_Statement
908 and then Present
(Name
(Orig
))
909 and then No
(Expression
(Orig
)));
910 Excep
:= Entity
(Name
(Orig
));
914 -- Here Excep is the exception to raise, and Cond is the condition
915 -- First prepare the call to Local_Raise (excep'address).
917 if RTE_Available
(RE_Local_Raise
) then
919 Make_Procedure_Call_Statement
(Loc
,
920 Name
=> New_Occurrence_Of
(RTE
(RE_Local_Raise
), Loc
),
921 Parameter_Associations
=> New_List
(
922 Unchecked_Convert_To
(RTE
(RE_Address
),
923 Make_Attribute_Reference
(Loc
,
924 Prefix
=> New_Occurrence_Of
(Excep
, Loc
),
925 Attribute_Name
=> Name_Identity
))));
927 -- Use null statement if Local_Raise not available
931 Make_Null_Statement
(Loc
);
934 -- If there is no condition, we rewrite as
937 -- Local_Raise (excep'Identity);
943 Make_Block_Statement
(Loc
,
944 Handled_Statement_Sequence
=>
945 Make_Handled_Sequence_Of_Statements
(Loc
,
946 Statements
=> New_List
(LR
, Goto_L1
))));
947 Set_Exception_Junk
(Raise_S
);
949 -- If there is a condition, we rewrite as
952 -- Local_Raise (excep'Identity);
958 Make_If_Statement
(Loc
,
960 Then_Statements
=> New_List
(LR
, Goto_L1
)));
964 end Replace_Raise_By_Goto
;
966 -- Start of processing for Expand_Exception_Handlers
969 Expand_Local_Exception_Handlers
;
971 -- Loop through handlers
973 Handler
:= First_Non_Pragma
(Handlrs
);
974 Handler_Loop
: while Present
(Handler
) loop
975 Next_Handler
:= Next_Non_Pragma
(Handler
);
977 -- Remove source handler if gnat debug flag .x is set
979 if Debug_Flag_Dot_X
and then Comes_From_Source
(Handler
) then
982 -- Remove handler if no exception propagation, generating a warning
983 -- if a source generated handler was not the target of a local raise.
986 if Restriction_Active
(No_Exception_Propagation
)
987 and then not Has_Local_Raise
(Handler
)
988 and then Comes_From_Source
(Handler
)
989 and then Warn_On_Non_Local_Exception
991 Warn_No_Exception_Propagation_Active
(Handler
);
993 ("\?this handler can never be entered, and has been removed",
997 if No_Exception_Propagation_Active
then
1000 -- Exception handler is active and retained and must be processed
1003 -- If an exception occurrence is present, then we must declare
1004 -- it and initialize it from the value stored in the TSD
1007 -- name : Exception_Occurrence;
1009 -- Save_Occurrence (name, Get_Current_Excep.all)
1013 if Present
(Choice_Parameter
(Handler
)) then
1015 Cparm
: constant Entity_Id
:= Choice_Parameter
(Handler
);
1016 Cloc
: constant Source_Ptr
:= Sloc
(Cparm
);
1017 Hloc
: constant Source_Ptr
:= Sloc
(Handler
);
1021 -- Note use of No_Location to hide this code from the
1022 -- debugger, so single stepping doesn't jump back and
1026 Make_Procedure_Call_Statement
(No_Location
,
1028 New_Occurrence_Of
(RTE
(RE_Save_Occurrence
),
1030 Parameter_Associations
=> New_List
(
1031 New_Occurrence_Of
(Cparm
, Cloc
),
1032 Make_Explicit_Dereference
(No_Location
,
1033 Make_Function_Call
(No_Location
,
1034 Name
=> Make_Explicit_Dereference
(No_Location
,
1036 (RTE
(RE_Get_Current_Excep
),
1039 Mark_Rewrite_Insertion
(Save
);
1040 Prepend
(Save
, Statements
(Handler
));
1043 Make_Object_Declaration
1045 Defining_Identifier
=> Cparm
,
1046 Object_Definition
=>
1048 (RTE
(RE_Exception_Occurrence
), Cloc
));
1049 Set_No_Initialization
(Obj_Decl
, True);
1052 Make_Exception_Handler
(Hloc
,
1053 Choice_Parameter
=> Empty
,
1054 Exception_Choices
=> Exception_Choices
(Handler
),
1056 Statements
=> New_List
(
1057 Make_Block_Statement
(Hloc
,
1058 Declarations
=> New_List
(Obj_Decl
),
1059 Handled_Statement_Sequence
=>
1060 Make_Handled_Sequence_Of_Statements
(Hloc
,
1061 Statements
=> Statements
(Handler
))))));
1063 -- Local raise statements can't occur, since exception
1064 -- handlers with choice parameters are not allowed when
1065 -- No_Exception_Propagation applies, so set attributes
1068 Set_Local_Raise_Statements
(Handler
, No_Elist
);
1069 Set_Local_Raise_Not_OK
(Handler
);
1072 (Statements
(Handler
), Suppress
=> All_Checks
);
1076 -- The processing at this point is rather different for the JVM
1077 -- case, so we completely separate the processing.
1079 -- For the VM case, we unconditionally call Update_Exception,
1080 -- passing a call to the intrinsic Current_Target_Exception
1081 -- (see JVM/.NET versions of Ada.Exceptions for details).
1083 if VM_Target
/= No_VM
then
1085 Arg
: constant Node_Id
:=
1086 Make_Function_Call
(Loc
,
1089 (RTE
(RE_Current_Target_Exception
), Loc
));
1091 Prepend_Call_To_Handler
1092 (RE_Update_Exception
, New_List
(Arg
));
1095 -- For the normal case, we have to worry about the state of
1096 -- abort deferral. Generally, we defer abort during runtime
1097 -- handling of exceptions. When control is passed to the
1098 -- handler, then in the normal case we undefer aborts. In
1099 -- any case this entire handling is relevant only if aborts
1102 elsif Abort_Allowed
then
1104 -- There are some special cases in which we do not do the
1105 -- undefer. In particular a finalization (AT END) handler
1106 -- wants to operate with aborts still deferred.
1108 -- We also suppress the call if this is the special handler
1109 -- for Abort_Signal, since if we are aborting, we want to
1110 -- keep aborts deferred (one abort is enough).
1112 -- If abort really needs to be deferred the expander must
1113 -- add this call explicitly, see
1114 -- Expand_N_Asynchronous_Select.
1117 Nkind
(First
(Exception_Choices
(Handler
))) =
1121 or else Entity
(First
(Exception_Choices
(Handler
))) /=
1126 All_Others
(First
(Exception_Choices
(Handler
))))
1127 and then Abort_Allowed
1129 Prepend_Call_To_Handler
(RE_Abort_Undefer
);
1135 Handler
:= Next_Handler
;
1136 end loop Handler_Loop
;
1138 -- If all handlers got removed, then remove the list. Note we cannot
1139 -- reference HSS here, since expanding local handlers may have buried
1140 -- the handlers in an inner block.
1142 if Is_Empty_List
(Handlrs
) then
1143 Set_Exception_Handlers
(Parent
(Handlrs
), No_List
);
1145 end Expand_Exception_Handlers
;
1147 ------------------------------------
1148 -- Expand_N_Exception_Declaration --
1149 ------------------------------------
1152 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1153 -- except : exception_data := (
1154 -- Handled_By_Other => False,
1156 -- Name_Length => exceptE'Length,
1157 -- Full_Name => exceptE'Address,
1158 -- HTable_Ptr => null,
1159 -- Import_Code => 0,
1160 -- Raise_Hook => null,
1163 -- (protecting test only needed if not at library level)
1165 -- exceptF : Boolean := True -- static data
1167 -- exceptF := False;
1168 -- Register_Exception (except'Unchecked_Access);
1171 procedure Expand_N_Exception_Declaration
(N
: Node_Id
) is
1172 Loc
: constant Source_Ptr
:= Sloc
(N
);
1173 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1174 L
: List_Id
:= New_List
;
1175 Flag_Id
: Entity_Id
;
1177 Name_Exname
: constant Name_Id
:= New_External_Name
(Chars
(Id
), 'E');
1178 Exname
: constant Node_Id
:=
1179 Make_Defining_Identifier
(Loc
, Name_Exname
);
1182 -- There is no expansion needed when compiling for the JVM since the
1183 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
1185 if VM_Target
/= No_VM
then
1189 -- Definition of the external name: nam : constant String := "A.B.NAME";
1192 Make_Object_Declaration
(Loc
,
1193 Defining_Identifier
=> Exname
,
1194 Constant_Present
=> True,
1195 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1196 Expression
=> Make_String_Literal
(Loc
, Full_Qualified_Name
(Id
))));
1198 Set_Is_Statically_Allocated
(Exname
);
1200 -- Create the aggregate list for type Standard.Exception_Type:
1201 -- Handled_By_Other component: False
1203 Append_To
(L
, New_Occurrence_Of
(Standard_False
, Loc
));
1205 -- Lang component: 'A'
1208 Make_Character_Literal
(Loc
,
1210 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('A'))));
1212 -- Name_Length component: Nam'Length
1215 Make_Attribute_Reference
(Loc
,
1216 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
1217 Attribute_Name
=> Name_Length
));
1219 -- Full_Name component: Standard.A_Char!(Nam'Address)
1221 Append_To
(L
, Unchecked_Convert_To
(Standard_A_Char
,
1222 Make_Attribute_Reference
(Loc
,
1223 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
1224 Attribute_Name
=> Name_Address
)));
1226 -- HTable_Ptr component: null
1228 Append_To
(L
, Make_Null
(Loc
));
1230 -- Import_Code component: 0
1232 Append_To
(L
, Make_Integer_Literal
(Loc
, 0));
1234 -- Raise_Hook component: null
1236 Append_To
(L
, Make_Null
(Loc
));
1238 Set_Expression
(N
, Make_Aggregate
(Loc
, Expressions
=> L
));
1239 Analyze_And_Resolve
(Expression
(N
), Etype
(Id
));
1241 -- Register_Exception (except'Unchecked_Access);
1243 if not No_Exception_Handlers_Set
1244 and then not Restriction_Active
(No_Exception_Registration
)
1247 Make_Procedure_Call_Statement
(Loc
,
1248 Name
=> New_Occurrence_Of
(RTE
(RE_Register_Exception
), Loc
),
1249 Parameter_Associations
=> New_List
(
1250 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
1251 Make_Attribute_Reference
(Loc
,
1252 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
1253 Attribute_Name
=> Name_Unrestricted_Access
)))));
1255 Set_Register_Exception_Call
(Id
, First
(L
));
1257 if not Is_Library_Level_Entity
(Id
) then
1258 Flag_Id
:= Make_Defining_Identifier
(Loc
,
1259 New_External_Name
(Chars
(Id
), 'F'));
1262 Make_Object_Declaration
(Loc
,
1263 Defining_Identifier
=> Flag_Id
,
1264 Object_Definition
=>
1265 New_Occurrence_Of
(Standard_Boolean
, Loc
),
1267 New_Occurrence_Of
(Standard_True
, Loc
)));
1269 Set_Is_Statically_Allocated
(Flag_Id
);
1272 Make_Assignment_Statement
(Loc
,
1273 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1274 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1276 Insert_After_And_Analyze
(N
,
1277 Make_Implicit_If_Statement
(N
,
1278 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1279 Then_Statements
=> L
));
1282 Insert_List_After_And_Analyze
(N
, L
);
1285 end Expand_N_Exception_Declaration
;
1287 ---------------------------------------------
1288 -- Expand_N_Handled_Sequence_Of_Statements --
1289 ---------------------------------------------
1291 procedure Expand_N_Handled_Sequence_Of_Statements
(N
: Node_Id
) is
1293 -- Expand exception handlers
1295 if Present
(Exception_Handlers
(N
))
1296 and then not Restriction_Active
(No_Exception_Handlers
)
1298 Expand_Exception_Handlers
(N
);
1301 -- If local exceptions are being expanded, the previous call will
1302 -- have rewritten the construct as a block and reanalyzed it. No
1303 -- further expansion is needed.
1305 if Analyzed
(N
) then
1309 -- Add clean up actions if required
1311 if Nkind
(Parent
(N
)) /= N_Package_Body
1312 and then Nkind
(Parent
(N
)) /= N_Accept_Statement
1313 and then Nkind
(Parent
(N
)) /= N_Extended_Return_Statement
1314 and then not Delay_Cleanups
(Current_Scope
)
1316 Expand_Cleanup_Actions
(Parent
(N
));
1318 Set_First_Real_Statement
(N
, First
(Statements
(N
)));
1320 end Expand_N_Handled_Sequence_Of_Statements
;
1322 -------------------------------------
1323 -- Expand_N_Raise_Constraint_Error --
1324 -------------------------------------
1326 procedure Expand_N_Raise_Constraint_Error
(N
: Node_Id
) is
1328 -- We adjust the condition to deal with the C/Fortran boolean case. This
1329 -- may well not be necessary, as all such conditions are generated by
1330 -- the expander and probably are all standard boolean, but who knows
1331 -- what strange optimization in future may require this adjustment!
1333 Adjust_Condition
(Condition
(N
));
1335 -- Now deal with possible local raise handling
1337 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1338 end Expand_N_Raise_Constraint_Error
;
1340 ----------------------------------
1341 -- Expand_N_Raise_Program_Error --
1342 ----------------------------------
1344 procedure Expand_N_Raise_Program_Error
(N
: Node_Id
) is
1346 -- We adjust the condition to deal with the C/Fortran boolean case. This
1347 -- may well not be necessary, as all such conditions are generated by
1348 -- the expander and probably are all standard boolean, but who knows
1349 -- what strange optimization in future may require this adjustment!
1351 Adjust_Condition
(Condition
(N
));
1353 -- Now deal with possible local raise handling
1355 Possible_Local_Raise
(N
, Standard_Program_Error
);
1356 end Expand_N_Raise_Program_Error
;
1358 ------------------------------
1359 -- Expand_N_Raise_Statement --
1360 ------------------------------
1362 procedure Expand_N_Raise_Statement
(N
: Node_Id
) is
1363 Loc
: constant Source_Ptr
:= Sloc
(N
);
1370 -- Processing for locally handled exception (exclude reraise case)
1372 if Present
(Name
(N
)) and then Nkind
(Name
(N
)) = N_Identifier
then
1374 or else Restriction_Active
(No_Exception_Propagation
)
1376 -- If we have a local handler, then note that this is potentially
1377 -- able to be transformed into a goto statement.
1379 H
:= Find_Local_Handler
(Entity
(Name
(N
)), N
);
1382 if Local_Raise_Statements
(H
) = No_Elist
then
1383 Set_Local_Raise_Statements
(H
, New_Elmt_List
);
1386 -- Append the new entry if it is not there already. Sometimes
1387 -- we have situations where due to reexpansion, the same node
1388 -- is analyzed twice and would otherwise be added twice.
1390 Append_Unique_Elmt
(N
, Local_Raise_Statements
(H
));
1391 Set_Has_Local_Raise
(H
);
1393 -- If no local handler, then generate no propagation warning
1396 Warn_If_No_Propagation
(N
);
1402 -- If a string expression is present, then the raise statement is
1403 -- converted to a call:
1405 -- Raise_Exception (exception-name'Identity, string);
1407 -- and there is nothing else to do.
1409 if Present
(Expression
(N
)) then
1411 -- Avoid passing exception-name'identity in runtimes in which this
1412 -- argument is not used. This avoids generating undefined references
1413 -- to these exceptions when compiling with no optimization
1415 if Configurable_Run_Time_On_Target
1416 and then (Restriction_Active
(No_Exception_Handlers
)
1418 Restriction_Active
(No_Exception_Propagation
))
1421 Make_Procedure_Call_Statement
(Loc
,
1422 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1423 Parameter_Associations
=> New_List
(
1424 New_Occurrence_Of
(RTE
(RE_Null_Id
), Loc
),
1428 Make_Procedure_Call_Statement
(Loc
,
1429 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1430 Parameter_Associations
=> New_List
(
1431 Make_Attribute_Reference
(Loc
,
1433 Attribute_Name
=> Name_Identity
),
1441 -- Remaining processing is for the case where no string expression
1444 -- There is no expansion needed for statement "raise <exception>;" when
1445 -- compiling for the JVM since the JVM has a built-in exception
1446 -- mechanism. However we need to keep the expansion for "raise;"
1447 -- statements. See 4jexcept.ads for details.
1449 if Present
(Name
(N
)) and then VM_Target
/= No_VM
then
1453 -- Don't expand a raise statement that does not come from source
1454 -- if we have already had configurable run-time violations, since
1455 -- most likely it will be junk cascaded nonsense.
1457 if Configurable_Run_Time_Violations
> 0
1458 and then not Comes_From_Source
(N
)
1463 -- Convert explicit raise of Program_Error, Constraint_Error, and
1464 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1465 -- all other raises will get normal expansion and be disallowed,
1466 -- but this is also faster in all modes).
1468 if Present
(Name
(N
)) and then Nkind
(Name
(N
)) = N_Identifier
then
1469 if Entity
(Name
(N
)) = Standard_Constraint_Error
then
1471 Make_Raise_Constraint_Error
(Loc
,
1472 Reason
=> CE_Explicit_Raise
));
1476 elsif Entity
(Name
(N
)) = Standard_Program_Error
then
1478 Make_Raise_Program_Error
(Loc
,
1479 Reason
=> PE_Explicit_Raise
));
1483 elsif Entity
(Name
(N
)) = Standard_Storage_Error
then
1485 Make_Raise_Storage_Error
(Loc
,
1486 Reason
=> SE_Explicit_Raise
));
1492 -- Case of name present, in this case we expand raise name to
1494 -- Raise_Exception (name'Identity, location_string);
1496 -- where location_string identifies the file/line of the raise
1498 if Present
(Name
(N
)) then
1500 Id
: Entity_Id
:= Entity
(Name
(N
));
1504 Build_Location_String
(Loc
);
1506 -- If the exception is a renaming, use the exception that it
1507 -- renames (which might be a predefined exception, e.g.).
1509 if Present
(Renamed_Object
(Id
)) then
1510 Id
:= Renamed_Object
(Id
);
1513 -- Build a C-compatible string in case of no exception handlers,
1514 -- since this is what the last chance handler is expecting.
1516 if No_Exception_Handlers_Set
then
1518 -- Generate an empty message if configuration pragma
1519 -- Suppress_Exception_Locations is set for this unit.
1521 if Opt
.Exception_Locations_Suppressed
then
1524 Name_Len
:= Name_Len
+ 1;
1527 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
1530 if Opt
.Exception_Locations_Suppressed
then
1534 Str
:= String_From_Name_Buffer
;
1536 -- For VMS exceptions, convert the raise into a call to
1537 -- lib$stop so it will be handled by __gnat_error_handler.
1539 if Is_VMS_Exception
(Id
) then
1541 Excep_Image
: String_Id
;
1545 if Present
(Interface_Name
(Id
)) then
1546 Excep_Image
:= Strval
(Interface_Name
(Id
));
1548 Get_Name_String
(Chars
(Id
));
1550 Excep_Image
:= String_From_Name_Buffer
;
1553 if Exception_Code
(Id
) /= No_Uint
then
1555 Make_Integer_Literal
(Loc
, Exception_Code
(Id
));
1558 Unchecked_Convert_To
(Standard_Integer
,
1559 Make_Function_Call
(Loc
,
1560 Name
=> New_Occurrence_Of
1561 (RTE
(RE_Import_Value
), Loc
),
1562 Parameter_Associations
=> New_List
1563 (Make_String_Literal
(Loc
,
1564 Strval
=> Excep_Image
))));
1568 Make_Procedure_Call_Statement
(Loc
,
1570 New_Occurrence_Of
(RTE
(RE_Lib_Stop
), Loc
),
1571 Parameter_Associations
=> New_List
(Cond
)));
1572 Analyze_And_Resolve
(Cond
, Standard_Integer
);
1575 -- Not VMS exception case, convert raise to call to the
1576 -- Raise_Exception routine.
1580 Make_Procedure_Call_Statement
(Loc
,
1581 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1582 Parameter_Associations
=> New_List
(
1583 Make_Attribute_Reference
(Loc
,
1585 Attribute_Name
=> Name_Identity
),
1586 Make_String_Literal
(Loc
,
1591 -- Case of no name present (reraise). We rewrite the raise to:
1593 -- Reraise_Occurrence_Always (EO);
1595 -- where EO is the current exception occurrence. If the current handler
1596 -- does not have a choice parameter specification, then we provide one.
1599 -- Find innermost enclosing exception handler (there must be one,
1600 -- since the semantics has already verified that this raise statement
1601 -- is valid, and a raise with no arguments is only permitted in the
1602 -- context of an exception handler.
1604 Ehand
:= Parent
(N
);
1605 while Nkind
(Ehand
) /= N_Exception_Handler
loop
1606 Ehand
:= Parent
(Ehand
);
1609 -- Make exception choice parameter if none present. Note that we do
1610 -- not need to put the entity on the entity chain, since no one will
1611 -- be referencing this entity by normal visibility methods.
1613 if No
(Choice_Parameter
(Ehand
)) then
1614 E
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
1615 Set_Choice_Parameter
(Ehand
, E
);
1616 Set_Ekind
(E
, E_Variable
);
1617 Set_Etype
(E
, RTE
(RE_Exception_Occurrence
));
1618 Set_Scope
(E
, Current_Scope
);
1621 -- Now rewrite the raise as a call to Reraise. A special case arises
1622 -- if this raise statement occurs in the context of a handler for
1623 -- all others (i.e. an at end handler). in this case we avoid
1624 -- the call to defer abort, cleanup routines are expected to be
1625 -- called in this case with aborts deferred.
1628 Ech
: constant Node_Id
:= First
(Exception_Choices
(Ehand
));
1632 if Nkind
(Ech
) = N_Others_Choice
1633 and then All_Others
(Ech
)
1635 Ent
:= RTE
(RE_Reraise_Occurrence_No_Defer
);
1637 Ent
:= RTE
(RE_Reraise_Occurrence_Always
);
1641 Make_Procedure_Call_Statement
(Loc
,
1642 Name
=> New_Occurrence_Of
(Ent
, Loc
),
1643 Parameter_Associations
=> New_List
(
1644 New_Occurrence_Of
(Choice_Parameter
(Ehand
), Loc
))));
1649 end Expand_N_Raise_Statement
;
1651 ----------------------------------
1652 -- Expand_N_Raise_Storage_Error --
1653 ----------------------------------
1655 procedure Expand_N_Raise_Storage_Error
(N
: Node_Id
) is
1657 -- We adjust the condition to deal with the C/Fortran boolean case. This
1658 -- may well not be necessary, as all such conditions are generated by
1659 -- the expander and probably are all standard boolean, but who knows
1660 -- what strange optimization in future may require this adjustment!
1662 Adjust_Condition
(Condition
(N
));
1664 -- Now deal with possible local raise handling
1666 Possible_Local_Raise
(N
, Standard_Storage_Error
);
1667 end Expand_N_Raise_Storage_Error
;
1669 --------------------------
1670 -- Possible_Local_Raise --
1671 --------------------------
1673 procedure Possible_Local_Raise
(N
: Node_Id
; E
: Entity_Id
) is
1675 -- Nothing to do if local raise optimization not active
1677 if not Debug_Flag_Dot_G
1678 and then not Restriction_Active
(No_Exception_Propagation
)
1683 -- Nothing to do if original node was an explicit raise, because in
1684 -- that case, we already generated the required warning for the raise.
1686 if Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
1690 -- Otherwise see if we have a local handler for the exception
1693 H
: constant Node_Id
:= Find_Local_Handler
(E
, N
);
1696 -- If so, mark that it has a local raise
1699 Set_Has_Local_Raise
(H
, True);
1701 -- Otherwise, if the No_Exception_Propagation restriction is active
1702 -- and the warning is enabled, generate the appropriate warnings.
1704 elsif Warn_On_Non_Local_Exception
1705 and then Restriction_Active
(No_Exception_Propagation
)
1707 Warn_No_Exception_Propagation_Active
(N
);
1709 if Configurable_Run_Time_Mode
then
1711 ("\?& may call Last_Chance_Handler", N
, E
);
1714 ("\?& may result in unhandled exception", N
, E
);
1718 end Possible_Local_Raise
;
1720 ------------------------------
1721 -- Expand_N_Subprogram_Info --
1722 ------------------------------
1724 procedure Expand_N_Subprogram_Info
(N
: Node_Id
) is
1725 Loc
: constant Source_Ptr
:= Sloc
(N
);
1728 -- For now, we replace an Expand_N_Subprogram_Info node with an
1729 -- attribute reference that gives the address of the procedure.
1730 -- This is because gigi does not yet recognize this node, and
1731 -- for the initial targets, this is the right value anyway.
1734 Make_Attribute_Reference
(Loc
,
1735 Prefix
=> Identifier
(N
),
1736 Attribute_Name
=> Name_Code_Address
));
1738 Analyze_And_Resolve
(N
, RTE
(RE_Code_Loc
));
1739 end Expand_N_Subprogram_Info
;
1741 ------------------------
1742 -- Find_Local_Handler --
1743 ------------------------
1745 function Find_Local_Handler
1747 Nod
: Node_Id
) return Node_Id
1754 SSE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
1755 -- This is used to test for wrapped actions below
1758 EHandle
: Entity_Id
;
1759 -- The entity Id's for the exception we are raising and handling, using
1760 -- the renamed exception if a Renamed_Entity is present.
1763 -- Never any local handler if all handlers removed
1765 if Debug_Flag_Dot_X
then
1769 -- Get the exception we are raising, allowing for renaming
1771 ERaise
:= Get_Renamed_Entity
(Ename
);
1773 -- We need to check if the node we are looking at is contained in
1776 -- Loop to search up the tree
1782 -- If we get to the top of the tree, or to a subprogram, task, entry,
1783 -- protected body, or accept statement without having found a
1784 -- matching handler, then there is no local handler.
1787 or else Nkind
(P
) = N_Subprogram_Body
1788 or else Nkind
(P
) = N_Task_Body
1789 or else Nkind
(P
) = N_Protected_Body
1790 or else Nkind
(P
) = N_Entry_Body
1791 or else Nkind
(P
) = N_Accept_Statement
1795 -- Test for handled sequence of statements with at least one
1796 -- exception handler which might be the one we are looking for.
1798 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
1799 and then Present
(Exception_Handlers
(P
))
1801 -- Before we proceed we need to check if the node N is covered
1802 -- by the statement part of P rather than one of its exception
1803 -- handlers (an exception handler obviously does not cover its
1806 -- This test is more delicate than might be thought. It is not
1807 -- just a matter of checking the Statements (P), because the node
1808 -- might be waiting to be wrapped in a transient scope, in which
1809 -- case it will end up in the block statements, even though it
1810 -- is not there now.
1812 if Is_List_Member
(N
)
1813 and then (List_Containing
(N
) = Statements
(P
)
1815 List_Containing
(N
) = SSE
.Actions_To_Be_Wrapped_Before
1817 List_Containing
(N
) = SSE
.Actions_To_Be_Wrapped_After
)
1819 -- Loop through exception handlers
1821 H
:= First
(Exception_Handlers
(P
));
1822 while Present
(H
) loop
1824 -- Loop through choices in one handler
1826 C
:= First
(Exception_Choices
(H
));
1827 while Present
(C
) loop
1829 -- Deal with others case
1831 if Nkind
(C
) = N_Others_Choice
then
1833 -- Matching others handler, but we need to ensure
1834 -- there is no choice parameter. If there is, then we
1835 -- don't have a local handler after all (since we do
1836 -- not allow choice parameters for local handlers).
1838 if No
(Choice_Parameter
(H
)) then
1844 -- If not others must be entity name
1846 elsif Nkind
(C
) /= N_Others_Choice
then
1847 pragma Assert
(Is_Entity_Name
(C
));
1848 pragma Assert
(Present
(Entity
(C
)));
1850 -- Get exception being handled, dealing with renaming
1852 EHandle
:= Get_Renamed_Entity
(Entity
(C
));
1854 -- If match, then check choice parameter
1856 if ERaise
= EHandle
then
1857 if No
(Choice_Parameter
(H
)) then
1875 end Find_Local_Handler
;
1877 ---------------------------------
1878 -- Get_Local_Raise_Call_Entity --
1879 ---------------------------------
1881 -- Note: this is primary provided for use by the back end in generating
1882 -- calls to Local_Raise. But it would be too late in the back end to call
1883 -- RTE if this actually caused a load/analyze of the unit. So what we do
1884 -- is to ensure there is a dummy call to this function during front end
1885 -- processing so that the unit gets loaded then, and not later.
1887 Local_Raise_Call_Entity
: Entity_Id
;
1888 Local_Raise_Call_Entity_Set
: Boolean := False;
1890 function Get_Local_Raise_Call_Entity
return Entity_Id
is
1892 if not Local_Raise_Call_Entity_Set
then
1893 Local_Raise_Call_Entity_Set
:= True;
1895 if RTE_Available
(RE_Local_Raise
) then
1896 Local_Raise_Call_Entity
:= RTE
(RE_Local_Raise
);
1898 Local_Raise_Call_Entity
:= Empty
;
1902 return Local_Raise_Call_Entity
;
1903 end Get_Local_Raise_Call_Entity
;
1905 -----------------------------
1906 -- Get_RT_Exception_Entity --
1907 -----------------------------
1909 function Get_RT_Exception_Entity
(R
: RT_Exception_Code
) return Entity_Id
is
1912 when RT_CE_Exceptions
=> return Standard_Constraint_Error
;
1913 when RT_PE_Exceptions
=> return Standard_Program_Error
;
1914 when RT_SE_Exceptions
=> return Standard_Storage_Error
;
1916 end Get_RT_Exception_Entity
;
1918 ----------------------
1919 -- Is_Non_Ada_Error --
1920 ----------------------
1922 function Is_Non_Ada_Error
(E
: Entity_Id
) return Boolean is
1924 if not OpenVMS_On_Target
then
1928 Get_Name_String
(Chars
(E
));
1930 -- Note: it is a little irregular for the body of exp_ch11 to know
1931 -- the details of the encoding scheme for names, but on the other
1932 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1934 if Name_Buffer
(1 .. 30) /= "system__aux_dec__non_ada_error" then
1939 end Is_Non_Ada_Error
;
1941 ----------------------------
1942 -- Warn_If_No_Propagation --
1943 ----------------------------
1945 procedure Warn_If_No_Propagation
(N
: Node_Id
) is
1947 if Restriction_Active
(No_Exception_Propagation
)
1948 and then Warn_On_Non_Local_Exception
1950 Warn_No_Exception_Propagation_Active
(N
);
1952 if Configurable_Run_Time_Mode
then
1954 ("\?Last_Chance_Handler will be called on exception", N
);
1957 ("\?execution may raise unhandled exception", N
);
1960 end Warn_If_No_Propagation
;
1962 ------------------------------------------
1963 -- Warn_No_Exception_Propagation_Active --
1964 ------------------------------------------
1966 procedure Warn_No_Exception_Propagation_Active
(N
: Node_Id
) is
1969 ("?pragma Restrictions (No_Exception_Propagation) in effect", N
);
1970 end Warn_No_Exception_Propagation_Active
;