1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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
));
107 Loc
: constant Source_Ptr
:= No_Location
;
108 -- Location used for expansion. We quite deliberately do not set a
109 -- specific source location for the expanded handler. This makes
110 -- sense since really the handler is not associated with specific
111 -- source. We used to set this to Sloc (Clean), but that caused
112 -- useless and annoying bouncing around of line numbers in the
113 -- debugger in some circumstances.
116 pragma Assert
(Present
(Clean
));
117 pragma Assert
(No
(Exception_Handlers
(HSS
)));
119 -- Don't expand if back end exception handling active
121 if Exception_Mechanism
= Back_End_Exceptions
then
125 -- Don't expand an At End handler if we have already had configurable
126 -- run-time violations, since likely this will just be a matter of
127 -- generating useless cascaded messages
129 if Configurable_Run_Time_Violations
> 0 then
133 -- Don't expand an At End handler if we are not allowing exceptions
134 -- or if exceptions are transformed into local gotos, and never
135 -- propagated (No_Exception_Propagation).
137 if No_Exception_Handlers_Set
then
141 if Present
(Block
) then
146 Make_Others_Choice
(Loc
);
147 Set_All_Others
(Ohandle
);
150 Make_Procedure_Call_Statement
(Loc
,
151 Name
=> New_Occurrence_Of
(Clean
, Loc
)));
153 -- Generate reraise statement as last statement of AT-END handler,
154 -- unless we are under control of No_Exception_Propagation, in which
155 -- case no exception propagation is possible anyway, so we do not need
156 -- a reraise (the AT END handler in this case is only for normal exits
157 -- not for exceptional exits). Also, we flag the Reraise statement as
158 -- being part of an AT END handler to prevent signalling this reraise
159 -- as a violation of the restriction when it is not set.
161 if not Restriction_Active
(No_Exception_Propagation
) then
163 Rstm
: constant Node_Id
:= Make_Raise_Statement
(Loc
);
165 Set_From_At_End
(Rstm
);
166 Append_To
(Stmnts
, Rstm
);
170 Set_Exception_Handlers
(HSS
, New_List
(
171 Make_Implicit_Exception_Handler
(Loc
,
172 Exception_Choices
=> New_List
(Ohandle
),
173 Statements
=> Stmnts
)));
175 Analyze_List
(Stmnts
, Suppress
=> All_Checks
);
176 Expand_Exception_Handlers
(HSS
);
178 if Present
(Block
) then
181 end Expand_At_End_Handler
;
183 -------------------------------
184 -- Expand_Exception_Handlers --
185 -------------------------------
187 procedure Expand_Exception_Handlers
(HSS
: Node_Id
) is
188 Handlrs
: constant List_Id
:= Exception_Handlers
(HSS
);
189 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
191 Others_Choice
: Boolean;
193 Next_Handler
: Node_Id
;
195 procedure Expand_Local_Exception_Handlers
;
196 -- This procedure handles the expansion of exception handlers for the
197 -- optimization of local raise statements into goto statements.
199 procedure Prepend_Call_To_Handler
201 Args
: List_Id
:= No_List
);
202 -- Routine to prepend a call to the procedure referenced by Proc at
203 -- the start of the handler code for the current Handler.
205 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
);
206 -- Raise_S is a raise statement (possibly expanded, and possibly of the
207 -- form of a Raise_xxx_Error node with a condition. This procedure is
208 -- called to replace the raise action with the (already analyzed) goto
209 -- statement passed as Goto_L1. This procedure also takes care of the
210 -- requirement of inserting a Local_Raise call where possible.
212 -------------------------------------
213 -- Expand_Local_Exception_Handlers --
214 -------------------------------------
216 -- There are two cases for this transformation. First the case of
217 -- explicit raise statements. For this case, the transformation we do
218 -- looks like this. Right now we have for example (where L1, L2 are
223 -- raise_exception (excep1'identity); -- was raise excep1
225 -- raise_exception (excep2'identity); -- was raise excep2
234 -- This gets transformed into:
237 -- L1 : label; -- marked Exception_Junk
238 -- L2 : label; -- marked Exception_Junk
239 -- L3 : label; -- marked Exception_Junk
241 -- begin -- marked Exception_Junk
243 -- local_raise (excep1'address); -- was raise excep1
246 -- local_raise (excep2'address); -- was raise excep2
256 -- goto L3; -- skip handler if no raise, marked Exception_Junk
258 -- <<L1>> -- local excep target label, marked Exception_Junk
259 -- begin -- marked Exception_Junk
262 -- goto L3; -- marked Exception_Junk
264 -- <<L2>> -- marked Exception_Junk
265 -- begin -- marked Exception_Junk
268 -- goto L3; -- marked Exception_Junk
269 -- <<L3>> -- marked Exception_Junk
272 -- Note: the reason we wrap the original statement sequence in an
273 -- inner block is that there may be raise statements within the
274 -- sequence of statements in the handlers, and we must ensure that
275 -- these are properly handled, and in particular, such raise statements
276 -- must not reenter the same exception handlers.
278 -- If the restriction No_Exception_Propagation is in effect, then we
279 -- can omit the exception handlers.
282 -- L1 : label; -- marked Exception_Junk
283 -- L2 : label; -- marked Exception_Junk
284 -- L3 : label; -- marked Exception_Junk
286 -- begin -- marked Exception_Junk
288 -- local_raise (excep1'address); -- was raise excep1
291 -- local_raise (excep2'address); -- was raise excep2
296 -- goto L3; -- skip handler if no raise, marked Exception_Junk
298 -- <<L1>> -- local excep target label, marked Exception_Junk
299 -- begin -- marked Exception_Junk
302 -- goto L3; -- marked Exception_Junk
304 -- <<L2>> -- marked Exception_Junk
305 -- begin -- marked Exception_Junk
309 -- <<L3>> -- marked Exception_Junk
312 -- The second case is for exceptions generated by the back end in one
313 -- of three situations:
315 -- 1. Front end generates N_Raise_xxx_Error node
316 -- 2. Front end sets Do_xxx_Check flag in subexpression node
317 -- 3. Back end detects a situation where an exception is appropriate
319 -- In all these cases, the current processing in gigi is to generate a
320 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
321 -- exception message and the exception to be raised, Constraint_Error,
322 -- Program_Error, or Storage_Error.
324 -- We could handle some subcases of 1 using the same front end expansion
325 -- into gotos, but even for case 1, we can't handle all cases, since
326 -- generating gotos in the middle of expressions is not possible (it's
327 -- possible at the gigi/gcc level, but not at the level of the GNAT
330 -- In any case, it seems easier to have a scheme which handles all three
331 -- cases in a uniform manner. So here is how we proceed in this case.
333 -- This procedure detects all handlers for these three exceptions,
334 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
335 -- OTHERS handlers that cover one or more of these cases).
337 -- If the handler meets the requirements for being the target of a local
338 -- raise, then the front end does the expansion described previously,
339 -- creating a label to be used as a goto target to raise the exception.
340 -- However, no attempt is made in the front end to convert any related
341 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
342 -- left unchanged and passed to the back end.
344 -- Instead, the front end generates three nodes
346 -- N_Push_Constraint_Error_Label
347 -- N_Push_Program_Error_Label
348 -- N_Push_Storage_Error_Label
350 -- The Push node is generated at the start of the statements
351 -- covered by the handler, and has as a parameter the label to be
352 -- used as the raise target.
354 -- N_Pop_Constraint_Error_Label
355 -- N_Pop_Program_Error_Label
356 -- N_Pop_Storage_Error_Label
358 -- The Pop node is generated at the end of the covered statements
359 -- and undoes the effect of the preceding corresponding Push node.
361 -- In the case where the handler does NOT meet the requirements, the
362 -- front end will still generate the Push and Pop nodes, but the label
363 -- field in the Push node will be empty signifying that for this region
364 -- of code, no optimization is possible.
366 -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set
367 -- since they are useless in this case, and in CodePeer mode, where
368 -- they serve no purpose and can intefere with the analysis.
370 -- The back end must maintain three stacks, one for each exception case,
371 -- the Push node pushes an entry onto the corresponding stack, and Pop
372 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
373 -- corresponding top stack entry has an non-empty label, a goto is
374 -- generated. This goto should be preceded by a call to Local_Raise as
377 -- An example of this transformation is as follows, given:
380 -- A : Integer range 1 .. 10;
384 -- when Constraint_Error =>
388 -- gets transformed to:
391 -- A : Integer range 1 .. 10;
398 -- %push_constraint_error_label (L1)
399 -- R1b : constant long_long_integer := long_long_integer?(b) +
400 -- long_long_integer?(c);
401 -- [constraint_error when
402 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
403 -- "overflow check failed"]
404 -- a := integer?(R1b);
405 -- %pop_constraint_error_Label
409 -- when constraint_error =>
413 -- goto L2; -- skip handler when exception not raised
414 -- <<L1>> -- target label for local exception
419 -- Note: the generated labels and goto statements all have the flag
420 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
421 -- this generated exception stuff when checking for missing return
422 -- statements (see circuitry in Check_Statement_Sequence).
424 -- Note: All of the processing described above occurs only if
425 -- restriction No_Exception_Propagation applies or debug flag .g is
428 CE_Locally_Handled
: Boolean := False;
429 SE_Locally_Handled
: Boolean := False;
430 PE_Locally_Handled
: Boolean := False;
431 -- These three flags indicate whether a handler for the corresponding
432 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
433 -- is present. If so the switch is set to True, the Exception_Label
434 -- field of the corresponding handler is set, and appropriate Push
435 -- and Pop nodes are inserted into the code.
437 Local_Expansion_Required
: Boolean := False;
438 -- Set True if we have at least one handler requiring local raise
439 -- expansion as described above.
441 procedure Expand_Local_Exception_Handlers
is
443 procedure Add_Exception_Label
(H
: Node_Id
);
444 -- H is an exception handler. First check for an Exception_Label
445 -- already allocated for H. If none, allocate one, set the field in
446 -- the handler node, add the label declaration, and set the flag
447 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
448 -- the call has no effect and Exception_Label is left empty.
450 procedure Add_Label_Declaration
(L
: Entity_Id
);
451 -- Add an implicit declaration of the given label to the declaration
452 -- list in the parent of the current sequence of handled statements.
455 Exc_Locally_Handled
: in out Boolean;
456 -- Flag indicating whether a local handler for this exception
457 -- has already been generated.
459 with function Make_Push_Label
(Loc
: Source_Ptr
) return Node_Id
;
460 -- Function to create a Push_xxx_Label node
462 with function Make_Pop_Label
(Loc
: Source_Ptr
) return Node_Id
;
463 -- Function to create a Pop_xxx_Label node
465 procedure Generate_Push_Pop
(H
: Node_Id
);
466 -- Common code for Generate_Push_Pop_xxx below, used to generate an
467 -- exception label and Push/Pop nodes for Constraint_Error,
468 -- Program_Error, or Storage_Error.
470 -------------------------
471 -- Add_Exception_Label --
472 -------------------------
474 procedure Add_Exception_Label
(H
: Node_Id
) is
476 if No
(Exception_Label
(H
))
477 and then not Local_Raise_Not_OK
(H
)
478 and then not Special_Exception_Package_Used
480 Local_Expansion_Required
:= True;
483 L
: constant Entity_Id
:= Make_Temporary
(Sloc
(H
), 'L');
485 Set_Exception_Label
(H
, L
);
486 Add_Label_Declaration
(L
);
489 end Add_Exception_Label
;
491 ---------------------------
492 -- Add_Label_Declaration --
493 ---------------------------
495 procedure Add_Label_Declaration
(L
: Entity_Id
) is
496 P
: constant Node_Id
:= Parent
(HSS
);
498 Decl_L
: constant Node_Id
:=
499 Make_Implicit_Label_Declaration
(Loc
,
500 Defining_Identifier
=> L
);
503 if Declarations
(P
) = No_List
then
504 Set_Declarations
(P
, Empty_List
);
507 Append
(Decl_L
, Declarations
(P
));
509 end Add_Label_Declaration
;
511 -----------------------
512 -- Generate_Push_Pop --
513 -----------------------
515 procedure Generate_Push_Pop
(H
: Node_Id
) is
517 if Restriction_Active
(No_Exception_Handlers
)
518 or else CodePeer_Mode
523 if Exc_Locally_Handled
then
526 Exc_Locally_Handled
:= True;
529 Add_Exception_Label
(H
);
532 F
: constant Node_Id
:= First
(Statements
(HSS
));
533 L
: constant Node_Id
:= Last
(Statements
(HSS
));
535 Push
: constant Node_Id
:= Make_Push_Label
(Sloc
(F
));
536 Pop
: constant Node_Id
:= Make_Pop_Label
(Sloc
(L
));
539 -- We make sure that a call to Get_Local_Raise_Call_Entity is
540 -- made during front end processing, so that when we need it
541 -- in the back end, it will already be available and loaded.
543 Discard_Node
(Get_Local_Raise_Call_Entity
);
545 -- Prepare and insert Push and Pop nodes
547 Set_Exception_Label
(Push
, Exception_Label
(H
));
548 Insert_Before
(F
, Push
);
551 Insert_After
(L
, Pop
);
554 end Generate_Push_Pop
;
556 -- Local declarations
558 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
559 Stmts
: List_Id
:= No_List
;
563 procedure Generate_Push_Pop_For_Constraint_Error
is
564 new Generate_Push_Pop
565 (Exc_Locally_Handled
=> CE_Locally_Handled
,
566 Make_Push_Label
=> Make_Push_Constraint_Error_Label
,
567 Make_Pop_Label
=> Make_Pop_Constraint_Error_Label
);
568 -- If no Push/Pop has been generated for CE yet, then set the flag
569 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
570 -- not already done), and generate Push/Pop nodes for the exception
571 -- label at the start and end of the statements of HSS.
573 procedure Generate_Push_Pop_For_Program_Error
is
574 new Generate_Push_Pop
575 (Exc_Locally_Handled
=> PE_Locally_Handled
,
576 Make_Push_Label
=> Make_Push_Program_Error_Label
,
577 Make_Pop_Label
=> Make_Pop_Program_Error_Label
);
578 -- If no Push/Pop has been generated for PE yet, then set the flag
579 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
580 -- not already done), and generate Push/Pop nodes for the exception
581 -- label at the start and end of the statements of HSS.
583 procedure Generate_Push_Pop_For_Storage_Error
is
584 new Generate_Push_Pop
585 (Exc_Locally_Handled
=> SE_Locally_Handled
,
586 Make_Push_Label
=> Make_Push_Storage_Error_Label
,
587 Make_Pop_Label
=> Make_Pop_Storage_Error_Label
);
588 -- If no Push/Pop has been generated for SE yet, then set the flag
589 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
590 -- not already done), and generate Push/Pop nodes for the exception
591 -- label at the start and end of the statements of HSS.
593 -- Start of processing for Expand_Local_Exception_Handlers
596 -- No processing if all exception handlers will get removed
598 if Debug_Flag_Dot_X
then
602 -- See for each handler if we have any local raises to expand
604 Handler
:= First_Non_Pragma
(Handlrs
);
605 while Present
(Handler
) loop
607 -- Note, we do not test Local_Raise_Not_OK here, because in the
608 -- case of Push/Pop generation we want to generate push with a
609 -- null label. The Add_Exception_Label routine has no effect if
610 -- Local_Raise_Not_OK is set, so this works as required.
612 if Present
(Local_Raise_Statements
(Handler
)) then
613 Add_Exception_Label
(Handler
);
616 -- If we are doing local raise to goto optimization (restriction
617 -- No_Exception_Propagation set or debug flag .g set), then check
618 -- to see if handler handles CE, PE, SE and if so generate the
619 -- appropriate push/pop sequence for the back end.
622 or else Restriction_Active
(No_Exception_Propagation
))
623 and then Has_Local_Raise
(Handler
)
625 Choice
:= First
(Exception_Choices
(Handler
));
626 while Present
(Choice
) loop
627 if Nkind
(Choice
) = N_Others_Choice
628 and then not All_Others
(Choice
)
630 Generate_Push_Pop_For_Constraint_Error
(Handler
);
631 Generate_Push_Pop_For_Program_Error
(Handler
);
632 Generate_Push_Pop_For_Storage_Error
(Handler
);
634 elsif Is_Entity_Name
(Choice
) then
635 Excep
:= Get_Renamed_Entity
(Entity
(Choice
));
637 if Excep
= Standard_Constraint_Error
then
638 Generate_Push_Pop_For_Constraint_Error
(Handler
);
639 elsif Excep
= Standard_Program_Error
then
640 Generate_Push_Pop_For_Program_Error
(Handler
);
641 elsif Excep
= Standard_Storage_Error
then
642 Generate_Push_Pop_For_Storage_Error
(Handler
);
650 Next_Non_Pragma
(Handler
);
653 -- Nothing to do if no handlers requiring the goto transformation
655 if not (Local_Expansion_Required
) then
659 -- Prepare to do the transformation
662 -- L3 is the label to exit the HSS
664 L3_Dent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
666 Labl_L3
: constant Node_Id
:=
668 Identifier
=> New_Occurrence_Of
(L3_Dent
, Loc
));
674 Set_Exception_Junk
(Labl_L3
);
675 Add_Label_Declaration
(L3_Dent
);
677 -- Wrap existing statements and handlers in an inner block
680 Make_Block_Statement
(Loc
,
681 Handled_Statement_Sequence
=> Relocate_Node
(HSS
));
682 Set_Exception_Junk
(Blk_Stm
);
685 Make_Handled_Sequence_Of_Statements
(Loc
,
686 Statements
=> New_List
(Blk_Stm
),
687 End_Label
=> Relocate_Node
(End_Label
(HSS
))));
689 -- Set block statement as analyzed, we don't want to actually call
690 -- Analyze on this block, it would cause a recursion in exception
691 -- handler processing which would mess things up.
693 Set_Analyzed
(Blk_Stm
);
695 -- Now loop through the exception handlers to deal with those that
696 -- are targets of local raise statements.
698 Handler
:= First_Non_Pragma
(Handlrs
);
699 while Present
(Handler
) loop
700 if Present
(Exception_Label
(Handler
)) then
702 -- This handler needs the goto expansion
705 Loc
: constant Source_Ptr
:= Sloc
(Handler
);
707 -- L1 is the start label for this handler
709 L1_Dent
: constant Entity_Id
:= Exception_Label
(Handler
);
711 Labl_L1
: constant Node_Id
:=
714 New_Occurrence_Of
(L1_Dent
, Loc
));
716 -- Jump to L1 to be used as replacement for the original
717 -- handler (used in the case where exception propagation
720 Name_L1
: constant Node_Id
:=
721 New_Occurrence_Of
(L1_Dent
, Loc
);
723 Goto_L1
: constant Node_Id
:=
724 Make_Goto_Statement
(Loc
,
727 -- Jump to L3 to be used at the end of handler
729 Name_L3
: constant Node_Id
:=
730 New_Occurrence_Of
(L3_Dent
, Loc
);
732 Goto_L3
: constant Node_Id
:=
733 Make_Goto_Statement
(Loc
,
736 H_Stmts
: constant List_Id
:= Statements
(Handler
);
739 Set_Exception_Junk
(Labl_L1
);
740 Set_Exception_Junk
(Goto_L3
);
742 -- Note: we do NOT set Exception_Junk in Goto_L1, since
743 -- this is a real transfer of control that we want the
744 -- Sem_Ch6.Check_Returns procedure to recognize properly.
746 -- Replace handler by a goto L1. We can mark this as
747 -- analyzed since it is fully formed, and we don't
748 -- want it going through any further checks. We save
749 -- the last statement location in the goto L1 node for
750 -- the benefit of Sem_Ch6.Check_Returns.
752 Set_Statements
(Handler
, New_List
(Goto_L1
));
753 Set_Analyzed
(Goto_L1
);
754 Set_Etype
(Name_L1
, Standard_Void_Type
);
756 -- Now replace all the raise statements by goto L1
758 if Present
(Local_Raise_Statements
(Handler
)) then
759 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
760 while Present
(Relmt
) loop
762 Raise_S
: constant Node_Id
:= Node
(Relmt
);
763 RLoc
: constant Source_Ptr
:= Sloc
(Raise_S
);
764 Name_L1
: constant Node_Id
:=
765 New_Occurrence_Of
(L1_Dent
, Loc
);
766 Goto_L1
: constant Node_Id
:=
767 Make_Goto_Statement
(RLoc
,
771 -- Replace raise by goto L1
773 Set_Analyzed
(Goto_L1
);
774 Set_Etype
(Name_L1
, Standard_Void_Type
);
775 Replace_Raise_By_Goto
(Raise_S
, Goto_L1
);
782 -- Add a goto L3 at end of statement list in block. The
783 -- first time, this is what skips over the exception
784 -- handlers in the normal case. Subsequent times, it
785 -- terminates the execution of the previous handler code,
786 -- and skips subsequent handlers.
788 Stmts
:= Statements
(HSS
);
790 Insert_After
(Last
(Stmts
), Goto_L3
);
791 Set_Analyzed
(Goto_L3
);
792 Set_Etype
(Name_L3
, Standard_Void_Type
);
794 -- Now we drop the label that marks the handler start,
795 -- followed by the statements of the handler.
797 Set_Etype
(Identifier
(Labl_L1
), Standard_Void_Type
);
799 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L1
);
802 Loc
: constant Source_Ptr
:= Sloc
(First
(H_Stmts
));
803 Blk
: constant Node_Id
:=
804 Make_Block_Statement
(Loc
,
805 Handled_Statement_Sequence
=>
806 Make_Handled_Sequence_Of_Statements
(Loc
,
807 Statements
=> H_Stmts
));
809 Set_Exception_Junk
(Blk
);
810 Insert_After_And_Analyze
(Last
(Stmts
), Blk
);
814 -- Here if we have local raise statements but the handler is
815 -- not suitable for processing with a local raise. In this
816 -- case we have to generate possible diagnostics.
818 elsif Has_Local_Raise
(Handler
)
819 and then Local_Raise_Statements
(Handler
) /= No_Elist
821 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
822 while Present
(Relmt
) loop
823 Warn_If_No_Propagation
(Node
(Relmt
));
831 -- Only remaining step is to drop the L3 label and we are done
833 Set_Etype
(Identifier
(Labl_L3
), Standard_Void_Type
);
835 -- If we had at least one handler, then we drop the label after
836 -- the last statement of that handler.
838 if Stmts
/= No_List
then
839 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L3
);
841 -- Otherwise we have removed all the handlers (this results from
842 -- use of pragma Restrictions (No_Exception_Propagation), and we
843 -- drop the label at the end of the statements of the HSS.
846 Insert_After_And_Analyze
(Last
(Statements
(HSS
)), Labl_L3
);
851 end Expand_Local_Exception_Handlers
;
853 -----------------------------
854 -- Prepend_Call_To_Handler --
855 -----------------------------
857 procedure Prepend_Call_To_Handler
859 Args
: List_Id
:= No_List
)
861 Ent
: constant Entity_Id
:= RTE
(Proc
);
864 -- If we have no Entity, then we are probably in no run time mode or
865 -- some weird error has occurred. In either case do nothing. Note use
866 -- of No_Location to hide this code from the debugger, so single
867 -- stepping doesn't jump back and forth.
869 if Present
(Ent
) then
871 Call
: constant Node_Id
:=
872 Make_Procedure_Call_Statement
(No_Location
,
873 Name
=> New_Occurrence_Of
(RTE
(Proc
), No_Location
),
874 Parameter_Associations
=> Args
);
877 Prepend_To
(Statements
(Handler
), Call
);
878 Analyze
(Call
, Suppress
=> All_Checks
);
881 end Prepend_Call_To_Handler
;
883 ---------------------------
884 -- Replace_Raise_By_Goto --
885 ---------------------------
887 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
) is
888 Loc
: constant Source_Ptr
:= Sloc
(Raise_S
);
895 -- If we have a null statement, it means that there is no replacement
896 -- needed (typically this results from a suppressed check).
898 if Nkind
(Raise_S
) = N_Null_Statement
then
901 -- Test for Raise_xxx_Error
903 elsif Nkind
(Raise_S
) = N_Raise_Constraint_Error
then
904 Excep
:= Standard_Constraint_Error
;
905 Cond
:= Condition
(Raise_S
);
907 elsif Nkind
(Raise_S
) = N_Raise_Storage_Error
then
908 Excep
:= Standard_Storage_Error
;
909 Cond
:= Condition
(Raise_S
);
911 elsif Nkind
(Raise_S
) = N_Raise_Program_Error
then
912 Excep
:= Standard_Program_Error
;
913 Cond
:= Condition
(Raise_S
);
915 -- The only other possibility is a node that is or used to be a
916 -- simple raise statement.
919 Orig
:= Original_Node
(Raise_S
);
920 pragma Assert
(Nkind
(Orig
) = N_Raise_Statement
921 and then Present
(Name
(Orig
))
922 and then No
(Expression
(Orig
)));
923 Excep
:= Entity
(Name
(Orig
));
927 -- Here Excep is the exception to raise, and Cond is the condition
928 -- First prepare the call to Local_Raise (excep'address).
930 if RTE_Available
(RE_Local_Raise
) then
932 Make_Procedure_Call_Statement
(Loc
,
933 Name
=> New_Occurrence_Of
(RTE
(RE_Local_Raise
), Loc
),
934 Parameter_Associations
=> New_List
(
935 Unchecked_Convert_To
(RTE
(RE_Address
),
936 Make_Attribute_Reference
(Loc
,
937 Prefix
=> New_Occurrence_Of
(Excep
, Loc
),
938 Attribute_Name
=> Name_Identity
))));
940 -- Use null statement if Local_Raise not available
944 Make_Null_Statement
(Loc
);
947 -- If there is no condition, we rewrite as
950 -- Local_Raise (excep'Identity);
956 Make_Block_Statement
(Loc
,
957 Handled_Statement_Sequence
=>
958 Make_Handled_Sequence_Of_Statements
(Loc
,
959 Statements
=> New_List
(LR
, Goto_L1
))));
960 Set_Exception_Junk
(Raise_S
);
962 -- If there is a condition, we rewrite as
965 -- Local_Raise (excep'Identity);
971 Make_If_Statement
(Loc
,
973 Then_Statements
=> New_List
(LR
, Goto_L1
)));
977 end Replace_Raise_By_Goto
;
979 -- Start of processing for Expand_Exception_Handlers
982 Expand_Local_Exception_Handlers
;
984 -- Loop through handlers
986 Handler
:= First_Non_Pragma
(Handlrs
);
987 Handler_Loop
: while Present
(Handler
) loop
988 Process_Statements_For_Controlled_Objects
(Handler
);
990 Next_Handler
:= Next_Non_Pragma
(Handler
);
992 -- Remove source handler if gnat debug flag .x is set
994 if Debug_Flag_Dot_X
and then Comes_From_Source
(Handler
) then
997 -- Remove handler if no exception propagation, generating a warning
998 -- if a source generated handler was not the target of a local raise.
1001 if Restriction_Active
(No_Exception_Propagation
)
1002 and then not Has_Local_Raise
(Handler
)
1003 and then Comes_From_Source
(Handler
)
1004 and then Warn_On_Non_Local_Exception
1006 Warn_No_Exception_Propagation_Active
(Handler
);
1008 ("\?X?this handler can never be entered, "
1009 & "and has been removed", Handler
);
1012 if No_Exception_Propagation_Active
then
1015 -- Exception handler is active and retained and must be processed
1018 -- If an exception occurrence is present, then we must declare
1019 -- it and initialize it from the value stored in the TSD
1022 -- name : Exception_Occurrence;
1024 -- Save_Occurrence (name, Get_Current_Excep.all)
1028 -- This expansion is not performed when using GCC ZCX. Gigi
1029 -- will insert a call to initialize the choice parameter.
1031 if Present
(Choice_Parameter
(Handler
))
1032 and then (Exception_Mechanism
/= Back_End_Exceptions
1033 or else CodePeer_Mode
)
1036 Cparm
: constant Entity_Id
:= Choice_Parameter
(Handler
);
1037 Cloc
: constant Source_Ptr
:= Sloc
(Cparm
);
1038 Hloc
: constant Source_Ptr
:= Sloc
(Handler
);
1042 -- Note: No_Location used to hide code from the debugger,
1043 -- so single stepping doesn't jump back and forth.
1046 Make_Procedure_Call_Statement
(No_Location
,
1049 (RTE
(RE_Save_Occurrence
), No_Location
),
1050 Parameter_Associations
=> New_List
(
1051 New_Occurrence_Of
(Cparm
, No_Location
),
1052 Make_Explicit_Dereference
(No_Location
,
1054 Make_Function_Call
(No_Location
,
1056 Make_Explicit_Dereference
(No_Location
,
1059 (RTE
(RE_Get_Current_Excep
),
1062 Mark_Rewrite_Insertion
(Save
);
1063 Prepend
(Save
, Statements
(Handler
));
1066 Make_Object_Declaration
(Cloc
,
1067 Defining_Identifier
=> Cparm
,
1068 Object_Definition
=>
1070 (RTE
(RE_Exception_Occurrence
), Cloc
));
1071 Set_No_Initialization
(Obj_Decl
, True);
1074 Make_Exception_Handler
(Hloc
,
1075 Choice_Parameter
=> Empty
,
1076 Exception_Choices
=> Exception_Choices
(Handler
),
1077 Statements
=> New_List
(
1078 Make_Block_Statement
(Hloc
,
1079 Declarations
=> New_List
(Obj_Decl
),
1080 Handled_Statement_Sequence
=>
1081 Make_Handled_Sequence_Of_Statements
(Hloc
,
1082 Statements
=> Statements
(Handler
))))));
1084 -- Local raise statements can't occur, since exception
1085 -- handlers with choice parameters are not allowed when
1086 -- No_Exception_Propagation applies, so set attributes
1089 Set_Local_Raise_Statements
(Handler
, No_Elist
);
1090 Set_Local_Raise_Not_OK
(Handler
);
1093 (Statements
(Handler
), Suppress
=> All_Checks
);
1097 -- The processing at this point is rather different for the JVM
1098 -- case, so we completely separate the processing.
1100 -- For the VM case, we unconditionally call Update_Exception,
1101 -- passing a call to the intrinsic Current_Target_Exception
1102 -- (see JVM/.NET versions of Ada.Exceptions for details).
1104 if VM_Target
/= No_VM
then
1106 Arg
: constant Node_Id
:=
1107 Make_Function_Call
(Loc
,
1110 (RTE
(RE_Current_Target_Exception
), Loc
));
1112 Prepend_Call_To_Handler
1113 (RE_Update_Exception
, New_List
(Arg
));
1116 -- For the normal case, we have to worry about the state of
1117 -- abort deferral. Generally, we defer abort during runtime
1118 -- handling of exceptions. When control is passed to the
1119 -- handler, then in the normal case we undefer aborts. In
1120 -- any case this entire handling is relevant only if aborts
1124 and then Exception_Mechanism
/= Back_End_Exceptions
1126 -- There are some special cases in which we do not do the
1127 -- undefer. In particular a finalization (AT END) handler
1128 -- wants to operate with aborts still deferred.
1130 -- We also suppress the call if this is the special handler
1131 -- for Abort_Signal, since if we are aborting, we want to
1132 -- keep aborts deferred (one abort is enough).
1134 -- If abort really needs to be deferred the expander must
1135 -- add this call explicitly, see
1136 -- Expand_N_Asynchronous_Select.
1139 Nkind
(First
(Exception_Choices
(Handler
))) =
1143 or else Entity
(First
(Exception_Choices
(Handler
))) /=
1148 All_Others
(First
(Exception_Choices
(Handler
))))
1150 Prepend_Call_To_Handler
(RE_Abort_Undefer
);
1156 Handler
:= Next_Handler
;
1157 end loop Handler_Loop
;
1159 -- If all handlers got removed, then remove the list. Note we cannot
1160 -- reference HSS here, since expanding local handlers may have buried
1161 -- the handlers in an inner block.
1163 if Is_Empty_List
(Handlrs
) then
1164 Set_Exception_Handlers
(Parent
(Handlrs
), No_List
);
1166 end Expand_Exception_Handlers
;
1168 ------------------------------------
1169 -- Expand_N_Exception_Declaration --
1170 ------------------------------------
1173 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1174 -- except : exception_data :=
1175 -- (Handled_By_Other => False,
1177 -- Name_Length => exceptE'Length,
1178 -- Full_Name => exceptE'Address,
1179 -- HTable_Ptr => null,
1180 -- Foreign_Data => null,
1181 -- Raise_Hook => null);
1183 -- (protecting test only needed if not at library level)
1185 -- exceptF : Boolean := True -- static data
1187 -- exceptF := False;
1188 -- Register_Exception (except'Unchecked_Access);
1191 procedure Expand_N_Exception_Declaration
(N
: Node_Id
) is
1192 Loc
: constant Source_Ptr
:= Sloc
(N
);
1193 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1194 L
: List_Id
:= New_List
;
1195 Flag_Id
: Entity_Id
;
1197 Name_Exname
: constant Name_Id
:= New_External_Name
(Chars
(Id
), 'E');
1198 Exname
: constant Node_Id
:=
1199 Make_Defining_Identifier
(Loc
, Name_Exname
);
1201 procedure Force_Static_Allocation_Of_Referenced_Objects
1202 (Aggregate
: Node_Id
);
1203 -- A specialized solution to one particular case of an ugly problem
1205 -- The given aggregate includes an Unchecked_Conversion as one of the
1206 -- component values. The call to Analyze_And_Resolve below ends up
1207 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1208 -- to introduce a (constant) temporary and then obtain the component
1209 -- value by evaluating the temporary.
1211 -- In the case of an exception declared within a subprogram (or any
1212 -- other dynamic scope), this is a bad transformation. The exception
1213 -- object is marked as being Statically_Allocated but the temporary is
1214 -- not. If the initial value of a Statically_Allocated declaration
1215 -- references a dynamically allocated object, this prevents static
1216 -- initialization of the object.
1218 -- We cope with this here by marking the temporary Statically_Allocated.
1219 -- It might seem cleaner to generalize this utility and then use it to
1220 -- enforce a rule that the entities referenced in the declaration of any
1221 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1222 -- entity must also be either Library_Level or hoisted. It turns out
1223 -- that this would be incompatible with the current treatment of an
1224 -- object which is local to a subprogram, subject to an Export pragma,
1225 -- not subject to an address clause, and whose declaration contains
1226 -- references to other local (non-hoisted) objects (e.g., in the initial
1227 -- value expression).
1229 ---------------------------------------------------
1230 -- Force_Static_Allocation_Of_Referenced_Objects --
1231 ---------------------------------------------------
1233 procedure Force_Static_Allocation_Of_Referenced_Objects
1234 (Aggregate
: Node_Id
)
1236 function Fixup_Node
(N
: Node_Id
) return Traverse_Result
;
1237 -- If the given node references a dynamically allocated object, then
1238 -- correct the declaration of the object.
1244 function Fixup_Node
(N
: Node_Id
) return Traverse_Result
is
1246 if Nkind
(N
) in N_Has_Entity
1247 and then Present
(Entity
(N
))
1248 and then not Is_Library_Level_Entity
(Entity
(N
))
1250 -- Note: the following test is not needed but it seems cleaner
1251 -- to do this test (this would be more important if procedure
1252 -- Force_Static_Allocation_Of_Referenced_Objects recursively
1253 -- traversed the declaration of an entity after marking it as
1254 -- statically allocated).
1256 and then not Is_Statically_Allocated
(Entity
(N
))
1258 Set_Is_Statically_Allocated
(Entity
(N
));
1264 procedure Fixup_Tree
is new Traverse_Proc
(Fixup_Node
);
1266 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1269 Fixup_Tree
(Aggregate
);
1270 end Force_Static_Allocation_Of_Referenced_Objects
;
1272 -- Start of processing for Expand_N_Exception_Declaration
1275 -- There is no expansion needed when compiling for the JVM since the
1276 -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
1279 if VM_Target
/= No_VM
then
1283 -- Definition of the external name: nam : constant String := "A.B.NAME";
1286 Make_Object_Declaration
(Loc
,
1287 Defining_Identifier
=> Exname
,
1288 Constant_Present
=> True,
1289 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1291 Make_String_Literal
(Loc
,
1292 Strval
=> Fully_Qualified_Name_String
(Id
))));
1294 Set_Is_Statically_Allocated
(Exname
);
1296 -- Create the aggregate list for type Standard.Exception_Type:
1297 -- Handled_By_Other component: False
1299 Append_To
(L
, New_Occurrence_Of
(Standard_False
, Loc
));
1301 -- Lang component: 'A'
1304 Make_Character_Literal
(Loc
,
1306 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('A'))));
1308 -- Name_Length component: Nam'Length
1311 Make_Attribute_Reference
(Loc
,
1312 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
1313 Attribute_Name
=> Name_Length
));
1315 -- Full_Name component: Standard.A_Char!(Nam'Address)
1317 Append_To
(L
, Unchecked_Convert_To
(Standard_A_Char
,
1318 Make_Attribute_Reference
(Loc
,
1319 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
1320 Attribute_Name
=> Name_Address
)));
1322 -- HTable_Ptr component: null
1324 Append_To
(L
, Make_Null
(Loc
));
1326 -- Foreign_Data component: null
1328 Append_To
(L
, Make_Null
(Loc
));
1330 -- Raise_Hook component: null
1332 Append_To
(L
, Make_Null
(Loc
));
1334 Set_Expression
(N
, Make_Aggregate
(Loc
, Expressions
=> L
));
1335 Analyze_And_Resolve
(Expression
(N
), Etype
(Id
));
1337 Force_Static_Allocation_Of_Referenced_Objects
(Expression
(N
));
1339 -- Register_Exception (except'Unchecked_Access);
1341 if not No_Exception_Handlers_Set
1342 and then not Restriction_Active
(No_Exception_Registration
)
1345 Make_Procedure_Call_Statement
(Loc
,
1346 Name
=> New_Occurrence_Of
(RTE
(RE_Register_Exception
), Loc
),
1347 Parameter_Associations
=> New_List
(
1348 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
1349 Make_Attribute_Reference
(Loc
,
1350 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
1351 Attribute_Name
=> Name_Unrestricted_Access
)))));
1353 Set_Register_Exception_Call
(Id
, First
(L
));
1355 if not Is_Library_Level_Entity
(Id
) then
1356 Flag_Id
:= Make_Defining_Identifier
(Loc
,
1357 New_External_Name
(Chars
(Id
), 'F'));
1360 Make_Object_Declaration
(Loc
,
1361 Defining_Identifier
=> Flag_Id
,
1362 Object_Definition
=>
1363 New_Occurrence_Of
(Standard_Boolean
, Loc
),
1365 New_Occurrence_Of
(Standard_True
, Loc
)));
1367 Set_Is_Statically_Allocated
(Flag_Id
);
1370 Make_Assignment_Statement
(Loc
,
1371 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1372 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1374 Insert_After_And_Analyze
(N
,
1375 Make_Implicit_If_Statement
(N
,
1376 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1377 Then_Statements
=> L
));
1380 Insert_List_After_And_Analyze
(N
, L
);
1383 end Expand_N_Exception_Declaration
;
1385 ---------------------------------------------
1386 -- Expand_N_Handled_Sequence_Of_Statements --
1387 ---------------------------------------------
1389 procedure Expand_N_Handled_Sequence_Of_Statements
(N
: Node_Id
) is
1391 -- Expand exception handlers
1393 if Present
(Exception_Handlers
(N
))
1394 and then not Restriction_Active
(No_Exception_Handlers
)
1396 Expand_Exception_Handlers
(N
);
1399 -- If local exceptions are being expanded, the previous call will
1400 -- have rewritten the construct as a block and reanalyzed it. No
1401 -- further expansion is needed.
1403 if Analyzed
(N
) then
1407 -- Add clean up actions if required
1409 if not Nkind_In
(Parent
(N
), N_Package_Body
,
1411 N_Extended_Return_Statement
)
1412 and then not Delay_Cleanups
(Current_Scope
)
1414 -- No cleanup action needed in thunks associated with interfaces
1415 -- because they only displace the pointer to the object.
1417 and then not Is_Thunk
(Current_Scope
)
1419 Expand_Cleanup_Actions
(Parent
(N
));
1421 Set_First_Real_Statement
(N
, First
(Statements
(N
)));
1423 end Expand_N_Handled_Sequence_Of_Statements
;
1425 -------------------------------------
1426 -- Expand_N_Raise_Constraint_Error --
1427 -------------------------------------
1429 procedure Expand_N_Raise_Constraint_Error
(N
: Node_Id
) is
1431 -- We adjust the condition to deal with the C/Fortran boolean case. This
1432 -- may well not be necessary, as all such conditions are generated by
1433 -- the expander and probably are all standard boolean, but who knows
1434 -- what strange optimization in future may require this adjustment!
1436 Adjust_Condition
(Condition
(N
));
1438 -- Now deal with possible local raise handling
1440 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1441 end Expand_N_Raise_Constraint_Error
;
1443 -------------------------------
1444 -- Expand_N_Raise_Expression --
1445 -------------------------------
1447 procedure Expand_N_Raise_Expression
(N
: Node_Id
) is
1448 Loc
: constant Source_Ptr
:= Sloc
(N
);
1449 Typ
: constant Entity_Id
:= Etype
(N
);
1453 Possible_Local_Raise
(N
, Entity
(Name
(N
)));
1455 -- Later we must teach the back end/gigi how to deal with this, but
1456 -- for now we will assume the type is Standard_Boolean and transform
1460 -- raise X [with string]
1462 -- raise Constraint_Error;
1464 -- unless the flag Convert_To_Return_False is set, in which case
1465 -- the transformation is to:
1470 -- raise Constraint_Error;
1472 -- The raise constraint error can never be executed. It is just a dummy
1473 -- node that can be labeled with an arbitrary type.
1475 RCE
:= Make_Raise_Constraint_Error
(Loc
, Reason
=> CE_Explicit_Raise
);
1476 Set_Etype
(RCE
, Typ
);
1478 if Convert_To_Return_False
(N
) then
1480 Make_Expression_With_Actions
(Loc
,
1481 Actions
=> New_List
(
1482 Make_Simple_Return_Statement
(Loc
,
1483 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
1484 Expression
=> RCE
));
1488 Make_Expression_With_Actions
(Loc
,
1489 Actions
=> New_List
(
1490 Make_Raise_Statement
(Loc
,
1492 Expression
=> Expression
(N
))),
1493 Expression
=> RCE
));
1496 Analyze_And_Resolve
(N
, Typ
);
1497 end Expand_N_Raise_Expression
;
1499 ----------------------------------
1500 -- Expand_N_Raise_Program_Error --
1501 ----------------------------------
1503 procedure Expand_N_Raise_Program_Error
(N
: Node_Id
) is
1505 -- We adjust the condition to deal with the C/Fortran boolean case. This
1506 -- may well not be necessary, as all such conditions are generated by
1507 -- the expander and probably are all standard boolean, but who knows
1508 -- what strange optimization in future may require this adjustment!
1510 Adjust_Condition
(Condition
(N
));
1512 -- Now deal with possible local raise handling
1514 Possible_Local_Raise
(N
, Standard_Program_Error
);
1515 end Expand_N_Raise_Program_Error
;
1517 ------------------------------
1518 -- Expand_N_Raise_Statement --
1519 ------------------------------
1521 procedure Expand_N_Raise_Statement
(N
: Node_Id
) is
1522 Loc
: constant Source_Ptr
:= Sloc
(N
);
1530 -- Processing for locally handled exception (exclude reraise case)
1532 if Present
(Name
(N
)) and then Nkind
(Name
(N
)) = N_Identifier
then
1534 or else Restriction_Active
(No_Exception_Propagation
)
1536 -- If we have a local handler, then note that this is potentially
1537 -- able to be transformed into a goto statement.
1539 H
:= Find_Local_Handler
(Entity
(Name
(N
)), N
);
1542 if Local_Raise_Statements
(H
) = No_Elist
then
1543 Set_Local_Raise_Statements
(H
, New_Elmt_List
);
1546 -- Append the new entry if it is not there already. Sometimes
1547 -- we have situations where due to reexpansion, the same node
1548 -- is analyzed twice and would otherwise be added twice.
1550 Append_Unique_Elmt
(N
, Local_Raise_Statements
(H
));
1551 Set_Has_Local_Raise
(H
);
1553 -- If no local handler, then generate no propagation warning
1556 Warn_If_No_Propagation
(N
);
1562 -- If a string expression is present, then the raise statement is
1563 -- converted to a call:
1564 -- Raise_Exception (exception-name'Identity, string);
1565 -- and there is nothing else to do.
1567 if Present
(Expression
(N
)) then
1569 -- Avoid passing exception-name'identity in runtimes in which this
1570 -- argument is not used. This avoids generating undefined references
1571 -- to these exceptions when compiling with no optimization
1573 if Configurable_Run_Time_On_Target
1574 and then (Restriction_Active
(No_Exception_Handlers
)
1576 Restriction_Active
(No_Exception_Propagation
))
1579 Make_Procedure_Call_Statement
(Loc
,
1580 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1581 Parameter_Associations
=> New_List
(
1582 New_Occurrence_Of
(RTE
(RE_Null_Id
), Loc
),
1586 Make_Procedure_Call_Statement
(Loc
,
1587 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1588 Parameter_Associations
=> New_List
(
1589 Make_Attribute_Reference
(Loc
,
1591 Attribute_Name
=> Name_Identity
),
1599 -- Remaining processing is for the case where no string expression is
1602 -- Don't expand a raise statement that does not come from source if we
1603 -- have already had configurable run-time violations, since most likely
1604 -- it will be junk cascaded nonsense.
1606 if Configurable_Run_Time_Violations
> 0
1607 and then not Comes_From_Source
(N
)
1612 -- Convert explicit raise of Program_Error, Constraint_Error, and
1613 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1614 -- all other raises will get normal expansion and be disallowed,
1615 -- but this is also faster in all modes). Propagate Comes_From_Source
1616 -- flag to the new node.
1618 if Present
(Name
(N
)) and then Nkind
(Name
(N
)) = N_Identifier
then
1619 Src
:= Comes_From_Source
(N
);
1621 if Entity
(Name
(N
)) = Standard_Constraint_Error
then
1623 Make_Raise_Constraint_Error
(Loc
, Reason
=> CE_Explicit_Raise
));
1624 Set_Comes_From_Source
(N
, Src
);
1628 elsif Entity
(Name
(N
)) = Standard_Program_Error
then
1630 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1631 Set_Comes_From_Source
(N
, Src
);
1635 elsif Entity
(Name
(N
)) = Standard_Storage_Error
then
1637 Make_Raise_Storage_Error
(Loc
, Reason
=> SE_Explicit_Raise
));
1638 Set_Comes_From_Source
(N
, Src
);
1644 -- Case of name present, in this case we expand raise name to
1646 -- Raise_Exception (name'Identity, location_string);
1648 -- where location_string identifies the file/line of the raise
1650 if Present
(Name
(N
)) then
1652 Id
: Entity_Id
:= Entity
(Name
(N
));
1656 Build_Location_String
(Loc
);
1658 -- If the exception is a renaming, use the exception that it
1659 -- renames (which might be a predefined exception, e.g.).
1661 if Present
(Renamed_Object
(Id
)) then
1662 Id
:= Renamed_Object
(Id
);
1665 -- Build a C-compatible string in case of no exception handlers,
1666 -- since this is what the last chance handler is expecting.
1668 if No_Exception_Handlers_Set
then
1670 -- Generate an empty message if configuration pragma
1671 -- Suppress_Exception_Locations is set for this unit.
1673 if Opt
.Exception_Locations_Suppressed
then
1676 Name_Len
:= Name_Len
+ 1;
1679 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
1682 if Opt
.Exception_Locations_Suppressed
then
1686 Str
:= String_From_Name_Buffer
;
1688 -- For VMS exceptions, convert the raise into a call to
1689 -- lib$stop so it will be handled by __gnat_error_handler.
1691 if Is_VMS_Exception
(Id
) then
1693 Excep_Image
: String_Id
;
1697 if Present
(Interface_Name
(Id
)) then
1698 Excep_Image
:= Strval
(Interface_Name
(Id
));
1700 Get_Name_String
(Chars
(Id
));
1702 Excep_Image
:= String_From_Name_Buffer
;
1705 if Exception_Code
(Id
) /= No_Uint
then
1707 Make_Integer_Literal
(Loc
, Exception_Code
(Id
));
1710 Unchecked_Convert_To
(Standard_Integer
,
1711 Make_Function_Call
(Loc
,
1712 Name
=> New_Occurrence_Of
1713 (RTE
(RE_Import_Value
), Loc
),
1714 Parameter_Associations
=> New_List
1715 (Make_String_Literal
(Loc
,
1716 Strval
=> Excep_Image
))));
1720 Make_Procedure_Call_Statement
(Loc
,
1722 New_Occurrence_Of
(RTE
(RE_Lib_Stop
), Loc
),
1723 Parameter_Associations
=> New_List
(Cond
)));
1724 Analyze_And_Resolve
(Cond
, Standard_Integer
);
1727 -- Not VMS exception case, convert raise to call to the
1728 -- Raise_Exception routine.
1732 Make_Procedure_Call_Statement
(Loc
,
1733 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1734 Parameter_Associations
=> New_List
(
1735 Make_Attribute_Reference
(Loc
,
1737 Attribute_Name
=> Name_Identity
),
1738 Make_String_Literal
(Loc
,
1743 -- Case of no name present (reraise). We rewrite the raise to:
1745 -- Reraise_Occurrence_Always (EO);
1747 -- where EO is the current exception occurrence. If the current handler
1748 -- does not have a choice parameter specification, then we provide one.
1751 -- Bypass expansion to a run-time call when back-end exception
1752 -- handling is active, unless the target is a VM, CodePeer or
1753 -- GNATprove. In CodePeer, raising an exception is treated as an
1754 -- error, while in GNATprove all code with exceptions falls outside
1755 -- the subset of code which can be formally analyzed.
1757 if VM_Target
= No_VM
1758 and then not CodePeer_Mode
1759 and then Exception_Mechanism
= Back_End_Exceptions
1764 -- Find innermost enclosing exception handler (there must be one,
1765 -- since the semantics has already verified that this raise statement
1766 -- is valid, and a raise with no arguments is only permitted in the
1767 -- context of an exception handler.
1769 Ehand
:= Parent
(N
);
1770 while Nkind
(Ehand
) /= N_Exception_Handler
loop
1771 Ehand
:= Parent
(Ehand
);
1774 -- Make exception choice parameter if none present. Note that we do
1775 -- not need to put the entity on the entity chain, since no one will
1776 -- be referencing this entity by normal visibility methods.
1778 if No
(Choice_Parameter
(Ehand
)) then
1779 E
:= Make_Temporary
(Loc
, 'E');
1780 Set_Choice_Parameter
(Ehand
, E
);
1781 Set_Ekind
(E
, E_Variable
);
1782 Set_Etype
(E
, RTE
(RE_Exception_Occurrence
));
1783 Set_Scope
(E
, Current_Scope
);
1786 -- Now rewrite the raise as a call to Reraise. A special case arises
1787 -- if this raise statement occurs in the context of a handler for
1788 -- all others (i.e. an at end handler). in this case we avoid
1789 -- the call to defer abort, cleanup routines are expected to be
1790 -- called in this case with aborts deferred.
1793 Ech
: constant Node_Id
:= First
(Exception_Choices
(Ehand
));
1797 if Nkind
(Ech
) = N_Others_Choice
1798 and then All_Others
(Ech
)
1800 Ent
:= RTE
(RE_Reraise_Occurrence_No_Defer
);
1802 Ent
:= RTE
(RE_Reraise_Occurrence_Always
);
1806 Make_Procedure_Call_Statement
(Loc
,
1807 Name
=> New_Occurrence_Of
(Ent
, Loc
),
1808 Parameter_Associations
=> New_List
(
1809 New_Occurrence_Of
(Choice_Parameter
(Ehand
), Loc
))));
1814 end Expand_N_Raise_Statement
;
1816 ----------------------------------
1817 -- Expand_N_Raise_Storage_Error --
1818 ----------------------------------
1820 procedure Expand_N_Raise_Storage_Error
(N
: Node_Id
) is
1822 -- We adjust the condition to deal with the C/Fortran boolean case. This
1823 -- may well not be necessary, as all such conditions are generated by
1824 -- the expander and probably are all standard boolean, but who knows
1825 -- what strange optimization in future may require this adjustment!
1827 Adjust_Condition
(Condition
(N
));
1829 -- Now deal with possible local raise handling
1831 Possible_Local_Raise
(N
, Standard_Storage_Error
);
1832 end Expand_N_Raise_Storage_Error
;
1834 --------------------------
1835 -- Possible_Local_Raise --
1836 --------------------------
1838 procedure Possible_Local_Raise
(N
: Node_Id
; E
: Entity_Id
) is
1840 -- Nothing to do if local raise optimization not active
1842 if not Debug_Flag_Dot_G
1843 and then not Restriction_Active
(No_Exception_Propagation
)
1848 -- Nothing to do if original node was an explicit raise, because in
1849 -- that case, we already generated the required warning for the raise.
1851 if Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
1855 -- Otherwise see if we have a local handler for the exception
1858 H
: constant Node_Id
:= Find_Local_Handler
(E
, N
);
1861 -- If so, mark that it has a local raise
1864 Set_Has_Local_Raise
(H
, True);
1866 -- Otherwise, if the No_Exception_Propagation restriction is active
1867 -- and the warning is enabled, generate the appropriate warnings.
1869 elsif Warn_On_Non_Local_Exception
1870 and then Restriction_Active
(No_Exception_Propagation
)
1872 Warn_No_Exception_Propagation_Active
(N
);
1874 if Configurable_Run_Time_Mode
then
1876 ("\?X?& may call Last_Chance_Handler", N
, E
);
1879 ("\?X?& may result in unhandled exception", N
, E
);
1883 end Possible_Local_Raise
;
1885 ------------------------------
1886 -- Expand_N_Subprogram_Info --
1887 ------------------------------
1889 procedure Expand_N_Subprogram_Info
(N
: Node_Id
) is
1890 Loc
: constant Source_Ptr
:= Sloc
(N
);
1893 -- For now, we replace an Expand_N_Subprogram_Info node with an
1894 -- attribute reference that gives the address of the procedure.
1895 -- This is because gigi does not yet recognize this node, and
1896 -- for the initial targets, this is the right value anyway.
1899 Make_Attribute_Reference
(Loc
,
1900 Prefix
=> Identifier
(N
),
1901 Attribute_Name
=> Name_Code_Address
));
1903 Analyze_And_Resolve
(N
, RTE
(RE_Code_Loc
));
1904 end Expand_N_Subprogram_Info
;
1906 ------------------------
1907 -- Find_Local_Handler --
1908 ------------------------
1910 function Find_Local_Handler
1912 Nod
: Node_Id
) return Node_Id
1919 SSE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
1920 -- This is used to test for wrapped actions below
1923 EHandle
: Entity_Id
;
1924 -- The entity Id's for the exception we are raising and handling, using
1925 -- the renamed exception if a Renamed_Entity is present.
1928 -- Never any local handler if all handlers removed
1930 if Debug_Flag_Dot_X
then
1934 -- Get the exception we are raising, allowing for renaming
1936 ERaise
:= Get_Renamed_Entity
(Ename
);
1938 -- We need to check if the node we are looking at is contained in
1941 -- Loop to search up the tree
1947 -- If we get to the top of the tree, or to a subprogram, task, entry,
1948 -- protected body, or accept statement without having found a
1949 -- matching handler, then there is no local handler.
1952 or else Nkind
(P
) = N_Subprogram_Body
1953 or else Nkind
(P
) = N_Task_Body
1954 or else Nkind
(P
) = N_Protected_Body
1955 or else Nkind
(P
) = N_Entry_Body
1956 or else Nkind
(P
) = N_Accept_Statement
1960 -- Test for handled sequence of statements with at least one
1961 -- exception handler which might be the one we are looking for.
1963 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
1964 and then Present
(Exception_Handlers
(P
))
1966 -- Before we proceed we need to check if the node N is covered
1967 -- by the statement part of P rather than one of its exception
1968 -- handlers (an exception handler obviously does not cover its
1971 -- This test is more delicate than might be thought. It is not
1972 -- just a matter of checking the Statements (P), because the node
1973 -- might be waiting to be wrapped in a transient scope, in which
1974 -- case it will end up in the block statements, even though it
1975 -- is not there now.
1977 if Is_List_Member
(N
) then
1979 LCN
: constant List_Id
:= List_Containing
(N
);
1982 if LCN
= Statements
(P
)
1984 LCN
= SSE
.Actions_To_Be_Wrapped_Before
1986 LCN
= SSE
.Actions_To_Be_Wrapped_After
1988 -- Loop through exception handlers
1990 H
:= First
(Exception_Handlers
(P
));
1991 while Present
(H
) loop
1993 -- Guard against other constructs appearing in the
1994 -- list of exception handlers.
1996 if Nkind
(H
) = N_Exception_Handler
then
1998 -- Loop through choices in one handler
2000 C
:= First
(Exception_Choices
(H
));
2001 while Present
(C
) loop
2003 -- Deal with others case
2005 if Nkind
(C
) = N_Others_Choice
then
2007 -- Matching others handler, but we need
2008 -- to ensure there is no choice parameter.
2009 -- If there is, then we don't have a local
2010 -- handler after all (since we do not allow
2011 -- choice parameters for local handlers).
2013 if No
(Choice_Parameter
(H
)) then
2019 -- If not others must be entity name
2021 elsif Nkind
(C
) /= N_Others_Choice
then
2022 pragma Assert
(Is_Entity_Name
(C
));
2023 pragma Assert
(Present
(Entity
(C
)));
2025 -- Get exception being handled, dealing with
2028 EHandle
:= Get_Renamed_Entity
(Entity
(C
));
2030 -- If match, then check choice parameter
2032 if ERaise
= EHandle
then
2033 if No
(Choice_Parameter
(H
)) then
2054 end Find_Local_Handler
;
2056 ---------------------------------
2057 -- Get_Local_Raise_Call_Entity --
2058 ---------------------------------
2060 -- Note: this is primary provided for use by the back end in generating
2061 -- calls to Local_Raise. But it would be too late in the back end to call
2062 -- RTE if this actually caused a load/analyze of the unit. So what we do
2063 -- is to ensure there is a dummy call to this function during front end
2064 -- processing so that the unit gets loaded then, and not later.
2066 Local_Raise_Call_Entity
: Entity_Id
;
2067 Local_Raise_Call_Entity_Set
: Boolean := False;
2069 function Get_Local_Raise_Call_Entity
return Entity_Id
is
2071 if not Local_Raise_Call_Entity_Set
then
2072 Local_Raise_Call_Entity_Set
:= True;
2074 if RTE_Available
(RE_Local_Raise
) then
2075 Local_Raise_Call_Entity
:= RTE
(RE_Local_Raise
);
2077 Local_Raise_Call_Entity
:= Empty
;
2081 return Local_Raise_Call_Entity
;
2082 end Get_Local_Raise_Call_Entity
;
2084 -----------------------------
2085 -- Get_RT_Exception_Entity --
2086 -----------------------------
2088 function Get_RT_Exception_Entity
(R
: RT_Exception_Code
) return Entity_Id
is
2091 when RT_CE_Exceptions
=> return Standard_Constraint_Error
;
2092 when RT_PE_Exceptions
=> return Standard_Program_Error
;
2093 when RT_SE_Exceptions
=> return Standard_Storage_Error
;
2095 end Get_RT_Exception_Entity
;
2097 ---------------------------
2098 -- Get_RT_Exception_Name --
2099 ---------------------------
2101 procedure Get_RT_Exception_Name
(Code
: RT_Exception_Code
) is
2104 when CE_Access_Check_Failed
=>
2105 Add_Str_To_Name_Buffer
("CE_Access_Check");
2106 when CE_Access_Parameter_Is_Null
=>
2107 Add_Str_To_Name_Buffer
("CE_Null_Access_Parameter");
2108 when CE_Discriminant_Check_Failed
=>
2109 Add_Str_To_Name_Buffer
("CE_Discriminant_Check");
2110 when CE_Divide_By_Zero
=>
2111 Add_Str_To_Name_Buffer
("CE_Divide_By_Zero");
2112 when CE_Explicit_Raise
=>
2113 Add_Str_To_Name_Buffer
("CE_Explicit_Raise");
2114 when CE_Index_Check_Failed
=>
2115 Add_Str_To_Name_Buffer
("CE_Index_Check");
2116 when CE_Invalid_Data
=>
2117 Add_Str_To_Name_Buffer
("CE_Invalid_Data");
2118 when CE_Length_Check_Failed
=>
2119 Add_Str_To_Name_Buffer
("CE_Length_Check");
2120 when CE_Null_Exception_Id
=>
2121 Add_Str_To_Name_Buffer
("CE_Null_Exception_Id");
2122 when CE_Null_Not_Allowed
=>
2123 Add_Str_To_Name_Buffer
("CE_Null_Not_Allowed");
2124 when CE_Overflow_Check_Failed
=>
2125 Add_Str_To_Name_Buffer
("CE_Overflow_Check");
2126 when CE_Partition_Check_Failed
=>
2127 Add_Str_To_Name_Buffer
("CE_Partition_Check");
2128 when CE_Range_Check_Failed
=>
2129 Add_Str_To_Name_Buffer
("CE_Range_Check");
2130 when CE_Tag_Check_Failed
=>
2131 Add_Str_To_Name_Buffer
("CE_Tag_Check");
2133 when PE_Access_Before_Elaboration
=>
2134 Add_Str_To_Name_Buffer
("PE_Access_Before_Elaboration");
2135 when PE_Accessibility_Check_Failed
=>
2136 Add_Str_To_Name_Buffer
("PE_Accessibility_Check");
2137 when PE_Address_Of_Intrinsic
=>
2138 Add_Str_To_Name_Buffer
("PE_Address_Of_Intrinsic");
2139 when PE_Aliased_Parameters
=>
2140 Add_Str_To_Name_Buffer
("PE_Aliased_Parameters");
2141 when PE_All_Guards_Closed
=>
2142 Add_Str_To_Name_Buffer
("PE_All_Guards_Closed");
2143 when PE_Bad_Predicated_Generic_Type
=>
2144 Add_Str_To_Name_Buffer
("PE_Bad_Predicated_Generic_Type");
2145 when PE_Current_Task_In_Entry_Body
=>
2146 Add_Str_To_Name_Buffer
("PE_Current_Task_In_Entry_Body");
2147 when PE_Duplicated_Entry_Address
=>
2148 Add_Str_To_Name_Buffer
("PE_Duplicated_Entry_Address");
2149 when PE_Explicit_Raise
=>
2150 Add_Str_To_Name_Buffer
("PE_Explicit_Raise");
2151 when PE_Finalize_Raised_Exception
=>
2152 Add_Str_To_Name_Buffer
("PE_Finalize_Raised_Exception");
2153 when PE_Implicit_Return
=>
2154 Add_Str_To_Name_Buffer
("PE_Implicit_Return");
2155 when PE_Misaligned_Address_Value
=>
2156 Add_Str_To_Name_Buffer
("PE_Misaligned_Address_Value");
2157 when PE_Missing_Return
=>
2158 Add_Str_To_Name_Buffer
("PE_Missing_Return");
2159 when PE_Overlaid_Controlled_Object
=>
2160 Add_Str_To_Name_Buffer
("PE_Overlaid_Controlled_Object");
2161 when PE_Potentially_Blocking_Operation
=>
2162 Add_Str_To_Name_Buffer
("PE_Potentially_Blocking_Operation");
2163 when PE_Stubbed_Subprogram_Called
=>
2164 Add_Str_To_Name_Buffer
("PE_Stubbed_Subprogram_Called");
2165 when PE_Unchecked_Union_Restriction
=>
2166 Add_Str_To_Name_Buffer
("PE_Unchecked_Union_Restriction");
2167 when PE_Non_Transportable_Actual
=>
2168 Add_Str_To_Name_Buffer
("PE_Non_Transportable_Actual");
2170 when SE_Empty_Storage_Pool
=>
2171 Add_Str_To_Name_Buffer
("SE_Empty_Storage_Pool");
2172 when SE_Explicit_Raise
=>
2173 Add_Str_To_Name_Buffer
("SE_Explicit_Raise");
2174 when SE_Infinite_Recursion
=>
2175 Add_Str_To_Name_Buffer
("SE_Infinite_Recursion");
2176 when SE_Object_Too_Large
=>
2177 Add_Str_To_Name_Buffer
("SE_Object_Too_Large");
2179 end Get_RT_Exception_Name
;
2181 ----------------------
2182 -- Is_Non_Ada_Error --
2183 ----------------------
2185 function Is_Non_Ada_Error
(E
: Entity_Id
) return Boolean is
2187 if not OpenVMS_On_Target
then
2191 Get_Name_String
(Chars
(E
));
2193 -- Note: it is a little irregular for the body of exp_ch11 to know
2194 -- the details of the encoding scheme for names, but on the other
2195 -- hand, gigi knows them, and this is for gigi's benefit anyway!
2197 if Name_Buffer
(1 .. 30) /= "system__aux_dec__non_ada_error" then
2202 end Is_Non_Ada_Error
;
2204 ----------------------------
2205 -- Warn_If_No_Propagation --
2206 ----------------------------
2208 procedure Warn_If_No_Propagation
(N
: Node_Id
) is
2210 if Restriction_Check_Required
(No_Exception_Propagation
)
2211 and then Warn_On_Non_Local_Exception
2213 Warn_No_Exception_Propagation_Active
(N
);
2215 if Configurable_Run_Time_Mode
then
2217 ("\?X?Last_Chance_Handler will be called on exception", N
);
2220 ("\?X?execution may raise unhandled exception", N
);
2223 end Warn_If_No_Propagation
;
2225 ------------------------------------------
2226 -- Warn_No_Exception_Propagation_Active --
2227 ------------------------------------------
2229 procedure Warn_No_Exception_Propagation_Active
(N
: Node_Id
) is
2232 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N
);
2233 end Warn_No_Exception_Propagation_Active
;