1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Exp_Ch7
; use Exp_Ch7
;
34 with Exp_Intr
; use Exp_Intr
;
35 with Exp_Util
; use Exp_Util
;
36 with Namet
; use Namet
;
37 with Nlists
; use Nlists
;
38 with Nmake
; use Nmake
;
40 with Restrict
; use Restrict
;
41 with Rident
; use Rident
;
42 with Rtsfind
; use Rtsfind
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Res
; use Sem_Res
;
46 with Sem_Util
; use Sem_Util
;
47 with Sinfo
; use Sinfo
;
48 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
49 with Sinfo
.Utils
; use Sinfo
.Utils
;
50 with Sinput
; use Sinput
;
51 with Snames
; use Snames
;
52 with Stand
; use Stand
;
53 with Stringt
; use Stringt
;
54 with Targparm
; use Targparm
;
55 with Tbuild
; use Tbuild
;
56 with Uintp
; use Uintp
;
58 package body Exp_Ch11
is
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
64 procedure Warn_No_Exception_Propagation_Active
(N
: Node_Id
);
65 -- Generates warning that pragma Restrictions (No_Exception_Propagation)
66 -- is in effect. Caller then generates appropriate continuation message.
67 -- N is the node on which the warning is placed.
69 procedure Warn_If_No_Propagation
(N
: Node_Id
);
70 -- Called for an exception raise that is not a local raise (and thus cannot
71 -- be optimized to a goto). Issues warning if No_Exception_Propagation
72 -- restriction is set. N is the node for the raise or equivalent call.
74 ---------------------------
75 -- Expand_At_End_Handler --
76 ---------------------------
78 -- For a handled statement sequence that has a cleanup (At_End_Proc
79 -- field set), an exception handler of the following form is required:
86 -- Note: this exception handler is treated rather specially by
87 -- subsequent expansion in two respects:
89 -- The normal call to Undefer_Abort is omitted
90 -- The raise call does not do Defer_Abort
92 -- This is because the current tasking code seems to assume that
93 -- the call to the cleanup routine that is made from an exception
94 -- handler for the abort signal is called with aborts deferred.
96 -- This expansion is only done if we have front end exception handling.
97 -- If we have back end exception handling, then the AT END handler is
98 -- left alone, and cleanups (including the exceptional case) are handled
101 -- In the front end case, the exception handler described above handles
102 -- the exceptional case. The AT END handler is left in the generated tree
103 -- and the code generator (e.g. gigi) must still handle proper generation
104 -- of cleanup calls for the non-exceptional case.
106 procedure Expand_At_End_Handler
(HSS
: Node_Id
; Blk_Id
: Entity_Id
) is
107 Clean
: constant Entity_Id
:= Entity
(At_End_Proc
(HSS
));
111 Loc
: constant Source_Ptr
:= No_Location
;
112 -- Location used for expansion. We quite deliberately do not set a
113 -- specific source location for the expanded handler. This makes
114 -- sense since really the handler is not associated with specific
115 -- source. We used to set this to Sloc (Clean), but that caused
116 -- useless and annoying bouncing around of line numbers in the
117 -- debugger in some circumstances.
120 pragma Assert
(Present
(Clean
));
121 pragma Assert
(No
(Exception_Handlers
(HSS
)));
123 -- Back end exception schemes don't need explicit handlers to
124 -- trigger AT-END actions on exceptional paths.
126 if Back_End_Exceptions
then
130 -- Don't expand an At End handler if we have already had configurable
131 -- run-time violations, since likely this will just be a matter of
132 -- generating useless cascaded messages
134 if Configurable_Run_Time_Violations
> 0 then
138 -- Don't expand an At End handler if we are not allowing exceptions
139 -- or if exceptions are transformed into local gotos, and never
140 -- propagated (No_Exception_Propagation).
142 if No_Exception_Handlers_Set
then
146 if Present
(Blk_Id
) then
151 Make_Others_Choice
(Loc
);
152 Set_All_Others
(Ohandle
);
155 Make_Procedure_Call_Statement
(Loc
,
156 Name
=> New_Occurrence_Of
(Clean
, Loc
)));
158 -- Generate reraise statement as last statement of AT-END handler,
159 -- unless we are under control of No_Exception_Propagation, in which
160 -- case no exception propagation is possible anyway, so we do not need
161 -- a reraise (the AT END handler in this case is only for normal exits
162 -- not for exceptional exits). Also, we flag the Reraise statement as
163 -- being part of an AT END handler to prevent signalling this reraise
164 -- as a violation of the restriction when it is not set.
166 if not Restriction_Active
(No_Exception_Propagation
) then
168 Rstm
: constant Node_Id
:= Make_Raise_Statement
(Loc
);
170 Set_From_At_End
(Rstm
);
171 Append_To
(Stmnts
, Rstm
);
175 Set_Exception_Handlers
(HSS
, New_List
(
176 Make_Implicit_Exception_Handler
(Loc
,
177 Exception_Choices
=> New_List
(Ohandle
),
178 Statements
=> Stmnts
)));
180 Analyze_List
(Stmnts
, Suppress
=> All_Checks
);
181 Expand_Exception_Handlers
(HSS
);
183 if Present
(Blk_Id
) then
186 end Expand_At_End_Handler
;
188 -------------------------------
189 -- Expand_Exception_Handlers --
190 -------------------------------
192 procedure Expand_Exception_Handlers
(HSS
: Node_Id
) is
193 Handlrs
: constant List_Id
:= Exception_Handlers
(HSS
);
194 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
197 Next_Handler
: Node_Id
;
199 procedure Expand_Local_Exception_Handlers
;
200 -- This procedure handles the expansion of exception handlers for the
201 -- optimization of local raise statements into goto statements.
203 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
);
204 -- Raise_S is a raise statement (possibly expanded, and possibly of the
205 -- form of a Raise_xxx_Error node with a condition. This procedure is
206 -- called to replace the raise action with the (already analyzed) goto
207 -- statement passed as Goto_L1. This procedure also takes care of the
208 -- requirement of inserting a Local_Raise call where possible.
210 -------------------------------------
211 -- Expand_Local_Exception_Handlers --
212 -------------------------------------
214 -- There are two cases for this transformation. First the case of
215 -- explicit raise statements. For this case, the transformation we do
216 -- looks like this. Right now we have for example (where L1, L2 are
221 -- raise_exception (excep1'identity); -- was raise excep1
223 -- raise_exception (excep2'identity); -- was raise excep2
232 -- This gets transformed into:
235 -- L1 : label; -- marked Exception_Junk
236 -- L2 : label; -- marked Exception_Junk
237 -- L3 : label; -- marked Exception_Junk
239 -- begin -- marked Exception_Junk
241 -- local_raise (excep1'address); -- was raise excep1
244 -- local_raise (excep2'address); -- was raise excep2
254 -- goto L3; -- skip handler if no raise, marked Exception_Junk
256 -- <<L1>> -- local excep target label, marked Exception_Junk
257 -- begin -- marked Exception_Junk
260 -- goto L3; -- marked Exception_Junk
262 -- <<L2>> -- marked Exception_Junk
263 -- begin -- marked Exception_Junk
266 -- goto L3; -- marked Exception_Junk
267 -- <<L3>> -- marked Exception_Junk
270 -- Note: the reason we wrap the original statement sequence in an
271 -- inner block is that there may be raise statements within the
272 -- sequence of statements in the handlers, and we must ensure that
273 -- these are properly handled, and in particular, such raise statements
274 -- must not reenter the same exception handlers.
276 -- If the restriction No_Exception_Propagation is in effect, then we
277 -- can omit the exception handlers.
280 -- L1 : label; -- marked Exception_Junk
281 -- L2 : label; -- marked Exception_Junk
282 -- L3 : label; -- marked Exception_Junk
284 -- begin -- marked Exception_Junk
286 -- local_raise (excep1'address); -- was raise excep1
289 -- local_raise (excep2'address); -- was raise excep2
294 -- goto L3; -- skip handler if no raise, marked Exception_Junk
296 -- <<L1>> -- local excep target label, marked Exception_Junk
297 -- begin -- marked Exception_Junk
300 -- goto L3; -- marked Exception_Junk
302 -- <<L2>> -- marked Exception_Junk
303 -- begin -- marked Exception_Junk
307 -- <<L3>> -- marked Exception_Junk
310 -- The second case is for exceptions generated by the back end in one
311 -- of three situations:
313 -- 1. Front end generates N_Raise_xxx_Error node
314 -- 2. Front end sets Do_xxx_Check flag in subexpression node
315 -- 3. Back end detects a situation where an exception is appropriate
317 -- In all these cases, the current processing in gigi is to generate a
318 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
319 -- exception message and the exception to be raised, Constraint_Error,
320 -- Program_Error, or Storage_Error.
322 -- We could handle some subcases of 1 using the same front end expansion
323 -- into gotos, but even for case 1, we can't handle all cases, since
324 -- generating gotos in the middle of expressions is not possible (it's
325 -- possible at the gigi/gcc level, but not at the level of the GNAT
328 -- In any case, it seems easier to have a scheme which handles all three
329 -- cases in a uniform manner. So here is how we proceed in this case.
331 -- This procedure detects all handlers for these three exceptions,
332 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
333 -- OTHERS handlers that cover one or more of these cases).
335 -- If the handler meets the requirements for being the target of a local
336 -- raise, then the front end does the expansion described previously,
337 -- creating a label to be used as a goto target to raise the exception.
338 -- However, no attempt is made in the front end to convert any related
339 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
340 -- left unchanged and passed to the back end.
342 -- Instead, the front end generates three nodes
344 -- N_Push_Constraint_Error_Label
345 -- N_Push_Program_Error_Label
346 -- N_Push_Storage_Error_Label
348 -- The Push node is generated at the start of the statements
349 -- covered by the handler, and has as a parameter the label to be
350 -- used as the raise target.
352 -- N_Pop_Constraint_Error_Label
353 -- N_Pop_Program_Error_Label
354 -- N_Pop_Storage_Error_Label
356 -- The Pop node is generated at the end of the covered statements
357 -- and undoes the effect of the preceding corresponding Push node.
359 -- In the case where the handler does NOT meet the requirements, the
360 -- front end will still generate the Push and Pop nodes, but the label
361 -- field in the Push node will be empty signifying that for this region
362 -- of code, no optimization is possible.
364 -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set
365 -- since they are useless in this case, and in CodePeer mode, where
366 -- they serve no purpose and can intefere with the analysis.
368 -- The back end must maintain three stacks, one for each exception case,
369 -- the Push node pushes an entry onto the corresponding stack, and Pop
370 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
371 -- corresponding top stack entry has an non-empty label, a goto is
372 -- generated. This goto should be preceded by a call to Local_Raise as
375 -- An example of this transformation is as follows, given:
378 -- A : Integer range 1 .. 10;
382 -- when Constraint_Error =>
386 -- gets transformed to:
389 -- A : Integer range 1 .. 10;
396 -- %push_constraint_error_label (L1)
397 -- R1b : constant long_long_integer := long_long_integer?(b) +
398 -- long_long_integer?(c);
399 -- [constraint_error when
400 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
401 -- "overflow check failed"]
402 -- a := integer?(R1b);
403 -- %pop_constraint_error_Label
407 -- when constraint_error =>
411 -- goto L2; -- skip handler when exception not raised
412 -- <<L1>> -- target label for local exception
417 -- Note: the generated labels and goto statements all have the flag
418 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
419 -- this generated exception stuff when checking for missing return
420 -- statements (see circuitry in Check_Statement_Sequence).
422 -- Note: All of the processing described above occurs only if
423 -- restriction No_Exception_Propagation applies or debug flag .g is
426 CE_Locally_Handled
: Boolean := False;
427 SE_Locally_Handled
: Boolean := False;
428 PE_Locally_Handled
: Boolean := False;
429 -- These three flags indicate whether a handler for the corresponding
430 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
431 -- is present. If so the switch is set to True, the Exception_Label
432 -- field of the corresponding handler is set, and appropriate Push
433 -- and Pop nodes are inserted into the code.
435 Local_Expansion_Required
: Boolean := False;
436 -- Set True if we have at least one handler requiring local raise
437 -- expansion as described above.
439 procedure Expand_Local_Exception_Handlers
is
440 procedure Add_Exception_Label
(H
: Node_Id
);
441 -- H is an exception handler. First check for an Exception_Label
442 -- already allocated for H. If none, allocate one, set the field in
443 -- the handler node, add the label declaration, and set the flag
444 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
445 -- the call has no effect and Exception_Label is left empty.
447 procedure Add_Label_Declaration
(L
: Entity_Id
);
448 -- Add an implicit declaration of the given label to the declaration
449 -- list in the parent of the current sequence of handled statements.
452 Exc_Locally_Handled
: in out Boolean;
453 -- Flag indicating whether a local handler for this exception
454 -- has already been generated.
456 with function Make_Push_Label
(Loc
: Source_Ptr
) return Node_Id
;
457 -- Function to create a Push_xxx_Label node
459 with function Make_Pop_Label
(Loc
: Source_Ptr
) return Node_Id
;
460 -- Function to create a Pop_xxx_Label node
462 procedure Generate_Push_Pop
(H
: Node_Id
);
463 -- Common code for Generate_Push_Pop_xxx below, used to generate an
464 -- exception label and Push/Pop nodes for Constraint_Error,
465 -- Program_Error, or Storage_Error.
467 -------------------------
468 -- Add_Exception_Label --
469 -------------------------
471 procedure Add_Exception_Label
(H
: Node_Id
) is
473 if No
(Exception_Label
(H
))
474 and then not Local_Raise_Not_OK
(H
)
475 and then not Special_Exception_Package_Used
477 Local_Expansion_Required
:= True;
480 L
: constant Entity_Id
:= Make_Temporary
(Sloc
(H
), 'L');
482 Set_Exception_Label
(H
, L
);
483 Add_Label_Declaration
(L
);
486 end Add_Exception_Label
;
488 ---------------------------
489 -- Add_Label_Declaration --
490 ---------------------------
492 procedure Add_Label_Declaration
(L
: Entity_Id
) is
493 P
: constant Node_Id
:= Parent
(HSS
);
495 Decl_L
: constant Node_Id
:=
496 Make_Implicit_Label_Declaration
(Loc
,
497 Defining_Identifier
=> L
);
500 if Declarations
(P
) = No_List
then
501 Set_Declarations
(P
, Empty_List
);
504 Append
(Decl_L
, Declarations
(P
));
506 end Add_Label_Declaration
;
508 -----------------------
509 -- Generate_Push_Pop --
510 -----------------------
512 procedure Generate_Push_Pop
(H
: Node_Id
) is
514 if Restriction_Active
(No_Exception_Handlers
)
515 or else CodePeer_Mode
520 if Exc_Locally_Handled
then
523 Exc_Locally_Handled
:= True;
526 Add_Exception_Label
(H
);
529 F
: constant Node_Id
:= First
(Statements
(HSS
));
530 L
: constant Node_Id
:= Last
(Statements
(HSS
));
532 Push
: constant Node_Id
:= Make_Push_Label
(Sloc
(F
));
533 Pop
: constant Node_Id
:= Make_Pop_Label
(Sloc
(L
));
536 -- We make sure that a call to Get_Local_Raise_Call_Entity is
537 -- made during front end processing, so that when we need it
538 -- in the back end, it will already be available and loaded.
540 Discard_Node
(Get_Local_Raise_Call_Entity
);
542 -- Prepare and insert Push and Pop nodes
544 Set_Exception_Label
(Push
, Exception_Label
(H
));
545 Insert_Before
(F
, Push
);
548 Insert_After
(L
, Pop
);
551 end Generate_Push_Pop
;
553 -- Local declarations
555 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
556 Stmts
: List_Id
:= No_List
;
560 procedure Generate_Push_Pop_For_Constraint_Error
is
561 new Generate_Push_Pop
562 (Exc_Locally_Handled
=> CE_Locally_Handled
,
563 Make_Push_Label
=> Make_Push_Constraint_Error_Label
,
564 Make_Pop_Label
=> Make_Pop_Constraint_Error_Label
);
565 -- If no Push/Pop has been generated for CE yet, then set the flag
566 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
567 -- not already done), and generate Push/Pop nodes for the exception
568 -- label at the start and end of the statements of HSS.
570 procedure Generate_Push_Pop_For_Program_Error
is
571 new Generate_Push_Pop
572 (Exc_Locally_Handled
=> PE_Locally_Handled
,
573 Make_Push_Label
=> Make_Push_Program_Error_Label
,
574 Make_Pop_Label
=> Make_Pop_Program_Error_Label
);
575 -- If no Push/Pop has been generated for PE yet, then set the flag
576 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
577 -- not already done), and generate Push/Pop nodes for the exception
578 -- label at the start and end of the statements of HSS.
580 procedure Generate_Push_Pop_For_Storage_Error
is
581 new Generate_Push_Pop
582 (Exc_Locally_Handled
=> SE_Locally_Handled
,
583 Make_Push_Label
=> Make_Push_Storage_Error_Label
,
584 Make_Pop_Label
=> Make_Pop_Storage_Error_Label
);
585 -- If no Push/Pop has been generated for SE yet, then set the flag
586 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
587 -- not already done), and generate Push/Pop nodes for the exception
588 -- label at the start and end of the statements of HSS.
590 -- Start of processing for Expand_Local_Exception_Handlers
593 -- No processing if all exception handlers will get removed
595 if Debug_Flag_Dot_X
then
599 -- See for each handler if we have any local raises to expand
601 Handler
:= First_Non_Pragma
(Handlrs
);
602 while Present
(Handler
) loop
604 -- Note, we do not test Local_Raise_Not_OK here, because in the
605 -- case of Push/Pop generation we want to generate push with a
606 -- null label. The Add_Exception_Label routine has no effect if
607 -- Local_Raise_Not_OK is set, so this works as required.
609 if Present
(Local_Raise_Statements
(Handler
)) then
610 Add_Exception_Label
(Handler
);
613 -- If we are doing local raise to goto optimization (restriction
614 -- No_Exception_Propagation set or debug flag .g set), then check
615 -- to see if handler handles CE, PE, SE and if so generate the
616 -- appropriate push/pop sequence for the back end.
619 or else Restriction_Active
(No_Exception_Propagation
))
620 and then Has_Local_Raise
(Handler
)
622 Choice
:= First
(Exception_Choices
(Handler
));
623 while Present
(Choice
) loop
624 if Nkind
(Choice
) = N_Others_Choice
625 and then not All_Others
(Choice
)
627 Generate_Push_Pop_For_Constraint_Error
(Handler
);
628 Generate_Push_Pop_For_Program_Error
(Handler
);
629 Generate_Push_Pop_For_Storage_Error
(Handler
);
631 elsif Is_Entity_Name
(Choice
) then
632 Excep
:= Get_Renamed_Entity
(Entity
(Choice
));
634 if Excep
= Standard_Constraint_Error
then
635 Generate_Push_Pop_For_Constraint_Error
(Handler
);
636 elsif Excep
= Standard_Program_Error
then
637 Generate_Push_Pop_For_Program_Error
(Handler
);
638 elsif Excep
= Standard_Storage_Error
then
639 Generate_Push_Pop_For_Storage_Error
(Handler
);
647 Next_Non_Pragma
(Handler
);
650 -- Nothing to do if no handlers requiring the goto transformation
652 if not (Local_Expansion_Required
) then
656 -- Prepare to do the transformation
659 -- L3 is the label to exit the HSS
661 L3_Dent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
663 Labl_L3
: constant Node_Id
:=
665 Identifier
=> New_Occurrence_Of
(L3_Dent
, Loc
));
671 Set_Exception_Junk
(Labl_L3
);
672 Add_Label_Declaration
(L3_Dent
);
674 -- Wrap existing statements and handlers in an inner block
677 Make_Block_Statement
(Loc
,
678 Handled_Statement_Sequence
=> Relocate_Node
(HSS
));
679 Set_Exception_Junk
(Blk_Stm
);
682 Make_Handled_Sequence_Of_Statements
(Loc
,
683 Statements
=> New_List
(Blk_Stm
),
684 End_Label
=> Relocate_Node
(End_Label
(HSS
))));
686 -- Set block statement as analyzed, we don't want to actually call
687 -- Analyze on this block, it would cause a recursion in exception
688 -- handler processing which would mess things up.
690 Set_Analyzed
(Blk_Stm
);
692 -- Now loop through the exception handlers to deal with those that
693 -- are targets of local raise statements.
695 Handler
:= First_Non_Pragma
(Handlrs
);
696 while Present
(Handler
) loop
697 if Present
(Exception_Label
(Handler
)) then
699 -- This handler needs the goto expansion
702 Loc
: constant Source_Ptr
:= Sloc
(Handler
);
704 -- L1 is the start label for this handler
706 L1_Dent
: constant Entity_Id
:= Exception_Label
(Handler
);
708 Labl_L1
: constant Node_Id
:=
711 New_Occurrence_Of
(L1_Dent
, Loc
));
713 -- Jump to L1 to be used as replacement for the original
714 -- handler (used in the case where exception propagation
717 Name_L1
: constant Node_Id
:=
718 New_Occurrence_Of
(L1_Dent
, Loc
);
720 Goto_L1
: constant Node_Id
:=
721 Make_Goto_Statement
(Loc
,
724 -- Jump to L3 to be used at the end of handler
726 Name_L3
: constant Node_Id
:=
727 New_Occurrence_Of
(L3_Dent
, Loc
);
729 Goto_L3
: constant Node_Id
:=
730 Make_Goto_Statement
(Loc
,
733 H_Stmts
: constant List_Id
:= Statements
(Handler
);
736 Set_Exception_Junk
(Labl_L1
);
737 Set_Exception_Junk
(Goto_L3
);
739 -- Note: we do NOT set Exception_Junk in Goto_L1, since
740 -- this is a real transfer of control that we want the
741 -- Sem_Ch6.Check_Returns procedure to recognize properly.
743 -- Replace handler by a goto L1. We can mark this as
744 -- analyzed since it is fully formed, and we don't
745 -- want it going through any further checks. We save
746 -- the last statement location in the goto L1 node for
747 -- the benefit of Sem_Ch6.Check_Returns.
749 Set_Statements
(Handler
, New_List
(Goto_L1
));
750 Set_Analyzed
(Goto_L1
);
751 Set_Etype
(Name_L1
, Standard_Void_Type
);
753 -- Now replace all the raise statements by goto L1
755 if Present
(Local_Raise_Statements
(Handler
)) then
756 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
757 while Present
(Relmt
) loop
759 Raise_S
: constant Node_Id
:= Node
(Relmt
);
760 RLoc
: constant Source_Ptr
:= Sloc
(Raise_S
);
761 Name_L1
: constant Node_Id
:=
762 New_Occurrence_Of
(L1_Dent
, Loc
);
763 Goto_L1
: constant Node_Id
:=
764 Make_Goto_Statement
(RLoc
,
768 -- Replace raise by goto L1
770 Set_Analyzed
(Goto_L1
);
771 Set_Etype
(Name_L1
, Standard_Void_Type
);
772 Replace_Raise_By_Goto
(Raise_S
, Goto_L1
);
779 -- Add a goto L3 at end of statement list in block. The
780 -- first time, this is what skips over the exception
781 -- handlers in the normal case. Subsequent times, it
782 -- terminates the execution of the previous handler code,
783 -- and skips subsequent handlers.
785 Stmts
:= Statements
(HSS
);
787 Insert_After
(Last
(Stmts
), Goto_L3
);
788 Set_Analyzed
(Goto_L3
);
789 Set_Etype
(Name_L3
, Standard_Void_Type
);
791 -- Now we drop the label that marks the handler start,
792 -- followed by the statements of the handler.
794 Set_Etype
(Identifier
(Labl_L1
), Standard_Void_Type
);
796 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L1
);
799 Loc
: constant Source_Ptr
:= Sloc
(First
(H_Stmts
));
800 Blk
: constant Node_Id
:=
801 Make_Block_Statement
(Loc
,
802 Handled_Statement_Sequence
=>
803 Make_Handled_Sequence_Of_Statements
(Loc
,
804 Statements
=> H_Stmts
));
806 Set_Exception_Junk
(Blk
);
807 Insert_After_And_Analyze
(Last
(Stmts
), Blk
);
811 -- Here if we have local raise statements but the handler is
812 -- not suitable for processing with a local raise. In this
813 -- case we have to generate possible diagnostics.
815 elsif Has_Local_Raise
(Handler
)
816 and then Local_Raise_Statements
(Handler
) /= No_Elist
818 Relmt
:= First_Elmt
(Local_Raise_Statements
(Handler
));
819 while Present
(Relmt
) loop
820 Warn_If_No_Propagation
(Node
(Relmt
));
828 -- Only remaining step is to drop the L3 label and we are done
830 Set_Etype
(Identifier
(Labl_L3
), Standard_Void_Type
);
832 -- If we had at least one handler, then we drop the label after
833 -- the last statement of that handler.
835 if Stmts
/= No_List
then
836 Insert_After_And_Analyze
(Last
(Stmts
), Labl_L3
);
838 -- Otherwise we have removed all the handlers (this results from
839 -- use of pragma Restrictions (No_Exception_Propagation), and we
840 -- drop the label at the end of the statements of the HSS.
843 Insert_After_And_Analyze
(Last
(Statements
(HSS
)), Labl_L3
);
848 end Expand_Local_Exception_Handlers
;
850 ---------------------------
851 -- Replace_Raise_By_Goto --
852 ---------------------------
854 procedure Replace_Raise_By_Goto
(Raise_S
: Node_Id
; Goto_L1
: Node_Id
) is
855 Loc
: constant Source_Ptr
:= Sloc
(Raise_S
);
862 -- If we have a null statement, it means that there is no replacement
863 -- needed (typically this results from a suppressed check).
865 if Nkind
(Raise_S
) = N_Null_Statement
then
868 -- Test for Raise_xxx_Error
870 elsif Nkind
(Raise_S
) = N_Raise_Constraint_Error
then
871 Excep
:= Standard_Constraint_Error
;
872 Cond
:= Condition
(Raise_S
);
874 elsif Nkind
(Raise_S
) = N_Raise_Storage_Error
then
875 Excep
:= Standard_Storage_Error
;
876 Cond
:= Condition
(Raise_S
);
878 elsif Nkind
(Raise_S
) = N_Raise_Program_Error
then
879 Excep
:= Standard_Program_Error
;
880 Cond
:= Condition
(Raise_S
);
882 -- The only other possibility is a node that is or used to be a
883 -- simple raise statement. Note that the string expression in the
884 -- original Raise statement is ignored.
887 Orig
:= Original_Node
(Raise_S
);
888 pragma Assert
(Nkind
(Orig
) = N_Raise_Statement
889 and then Present
(Name
(Orig
)));
890 Excep
:= Entity
(Name
(Orig
));
894 -- Here Excep is the exception to raise, and Cond is the condition
895 -- First prepare the call to Local_Raise (excep'address).
897 if RTE_Available
(RE_Local_Raise
) then
899 Make_Procedure_Call_Statement
(Loc
,
900 Name
=> New_Occurrence_Of
(RTE
(RE_Local_Raise
), Loc
),
901 Parameter_Associations
=> New_List
(
902 Unchecked_Convert_To
(RTE
(RE_Address
),
903 Make_Attribute_Reference
(Loc
,
904 Prefix
=> New_Occurrence_Of
(Excep
, Loc
),
905 Attribute_Name
=> Name_Identity
))));
907 -- Use null statement if Local_Raise not available
911 Make_Null_Statement
(Loc
);
914 -- If there is no condition, we rewrite as
917 -- Local_Raise (excep'Identity);
923 Make_Block_Statement
(Loc
,
924 Handled_Statement_Sequence
=>
925 Make_Handled_Sequence_Of_Statements
(Loc
,
926 Statements
=> New_List
(LR
, Goto_L1
))));
927 Set_Exception_Junk
(Raise_S
);
929 -- If there is a condition, we rewrite as
932 -- Local_Raise (excep'Identity);
938 Make_If_Statement
(Loc
,
940 Then_Statements
=> New_List
(LR
, Goto_L1
)));
944 end Replace_Raise_By_Goto
;
946 -- Start of processing for Expand_Exception_Handlers
949 Expand_Local_Exception_Handlers
;
951 -- Loop through handlers
953 Handler
:= First_Non_Pragma
(Handlrs
);
954 Handler_Loop
: while Present
(Handler
) loop
955 Process_Statements_For_Controlled_Objects
(Handler
);
957 Next_Handler
:= Next_Non_Pragma
(Handler
);
959 -- Remove source handler if gnat debug flag .x is set
961 if Debug_Flag_Dot_X
and then Comes_From_Source
(Handler
) then
964 -- Remove handler if no exception propagation, generating a warning
965 -- if a source generated handler was not the target of a local raise.
968 if not Has_Local_Raise
(Handler
)
969 and then Comes_From_Source
(Handler
)
971 Warn_If_No_Local_Raise
(Handler
);
974 if No_Exception_Propagation_Active
then
977 -- Exception handler is active and retained and must be processed
980 -- If an exception occurrence is present, then we must declare
981 -- it and initialize it from the value stored in the TSD
984 -- name : Exception_Occurrence;
986 -- Save_Occurrence (name, Get_Current_Excep.all)
990 -- This expansion is only performed when using front-end
991 -- exceptions. Gigi will insert a call to initialize the
994 if Present
(Choice_Parameter
(Handler
))
995 and then (Front_End_Exceptions
996 or else CodePeer_Mode
)
999 Cparm
: constant Entity_Id
:= Choice_Parameter
(Handler
);
1000 Cloc
: constant Source_Ptr
:= Sloc
(Cparm
);
1001 Hloc
: constant Source_Ptr
:= Sloc
(Handler
);
1005 -- Note: No_Location used to hide code from the debugger,
1006 -- so single stepping doesn't jump back and forth.
1009 Make_Procedure_Call_Statement
(No_Location
,
1012 (RTE
(RE_Save_Occurrence
), No_Location
),
1013 Parameter_Associations
=> New_List
(
1014 New_Occurrence_Of
(Cparm
, No_Location
),
1015 Make_Explicit_Dereference
(No_Location
,
1017 Make_Function_Call
(No_Location
,
1019 Make_Explicit_Dereference
(No_Location
,
1022 (RTE
(RE_Get_Current_Excep
),
1025 Mark_Rewrite_Insertion
(Save
);
1026 Prepend
(Save
, Statements
(Handler
));
1029 Make_Object_Declaration
(Cloc
,
1030 Defining_Identifier
=> Cparm
,
1031 Object_Definition
=>
1033 (RTE
(RE_Exception_Occurrence
), Cloc
));
1034 Set_No_Initialization
(Obj_Decl
, True);
1037 Make_Exception_Handler
(Hloc
,
1038 Choice_Parameter
=> Empty
,
1039 Exception_Choices
=> Exception_Choices
(Handler
),
1040 Statements
=> New_List
(
1041 Make_Block_Statement
(Hloc
,
1042 Declarations
=> New_List
(Obj_Decl
),
1043 Handled_Statement_Sequence
=>
1044 Make_Handled_Sequence_Of_Statements
(Hloc
,
1045 Statements
=> Statements
(Handler
))))));
1047 -- Local raise statements can't occur, since exception
1048 -- handlers with choice parameters are not allowed when
1049 -- No_Exception_Propagation applies, so set attributes
1052 Set_Local_Raise_Statements
(Handler
, No_Elist
);
1053 Set_Local_Raise_Not_OK
(Handler
);
1056 (Statements
(Handler
), Suppress
=> All_Checks
);
1062 Handler
:= Next_Handler
;
1063 end loop Handler_Loop
;
1065 -- If all handlers got removed, then remove the list. Note we cannot
1066 -- reference HSS here, since expanding local handlers may have buried
1067 -- the handlers in an inner block.
1069 if Is_Empty_List
(Handlrs
) then
1070 Set_Exception_Handlers
(Parent
(Handlrs
), No_List
);
1072 end Expand_Exception_Handlers
;
1074 ------------------------------------
1075 -- Expand_N_Exception_Declaration --
1076 ------------------------------------
1079 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1080 -- except : exception_data :=
1081 -- (Handled_By_Other => False,
1083 -- Name_Length => exceptE'Length,
1084 -- Full_Name => exceptE'Address,
1085 -- HTable_Ptr => null,
1086 -- Foreign_Data => null,
1087 -- Raise_Hook => null);
1089 -- (protecting test only needed if not at library level)
1091 -- exceptF : aliased System.Atomic_Operations.Test_And_Set.
1092 -- .Test_And_Set_Flag; -- static data
1093 -- if not Atomic_Test_And_Set (exceptF) then
1094 -- Register_Exception (except'Unrestricted_Access);
1097 -- If a No_Tasking restriction is in effect, or if Test_And_Set_Flag
1098 -- is unavailable, then use Boolean instead. In that case, we generate:
1100 -- exceptF : Boolean := True; -- static data
1102 -- ExceptF := False;
1103 -- Register_Exception (except'Unrestricted_Access);
1106 procedure Expand_N_Exception_Declaration
(N
: Node_Id
) is
1107 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1108 Loc
: constant Source_Ptr
:= Sloc
(N
);
1110 procedure Force_Static_Allocation_Of_Referenced_Objects
1111 (Aggregate
: Node_Id
);
1112 -- A specialized solution to one particular case of an ugly problem
1114 -- The given aggregate includes an Unchecked_Conversion as one of the
1115 -- component values. The call to Analyze_And_Resolve below ends up
1116 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1117 -- to introduce a (constant) temporary and then obtain the component
1118 -- value by evaluating the temporary.
1120 -- In the case of an exception declared within a subprogram (or any
1121 -- other dynamic scope), this is a bad transformation. The exception
1122 -- object is marked as being Statically_Allocated but the temporary is
1123 -- not. If the initial value of a Statically_Allocated declaration
1124 -- references a dynamically allocated object, this prevents static
1125 -- initialization of the object.
1127 -- We cope with this here by marking the temporary Statically_Allocated.
1128 -- It might seem cleaner to generalize this utility and then use it to
1129 -- enforce a rule that the entities referenced in the declaration of any
1130 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1131 -- entity must also be either Library_Level or hoisted. It turns out
1132 -- that this would be incompatible with the current treatment of an
1133 -- object which is local to a subprogram, subject to an Export pragma,
1134 -- not subject to an address clause, and whose declaration contains
1135 -- references to other local (non-hoisted) objects (e.g., in the initial
1136 -- value expression).
1138 function Null_String
return String_Id
;
1139 -- Build a null-terminated empty string
1141 ---------------------------------------------------
1142 -- Force_Static_Allocation_Of_Referenced_Objects --
1143 ---------------------------------------------------
1145 procedure Force_Static_Allocation_Of_Referenced_Objects
1146 (Aggregate
: Node_Id
)
1148 function Fixup_Node
(N
: Node_Id
) return Traverse_Result
;
1149 -- If the given node references a dynamically allocated object, then
1150 -- correct the declaration of the object.
1156 function Fixup_Node
(N
: Node_Id
) return Traverse_Result
is
1158 if Nkind
(N
) in N_Has_Entity
1159 and then Present
(Entity
(N
))
1160 and then not Is_Library_Level_Entity
(Entity
(N
))
1162 -- Note: the following test is not needed but it seems cleaner
1163 -- to do this test (this would be more important if procedure
1164 -- Force_Static_Allocation_Of_Referenced_Objects recursively
1165 -- traversed the declaration of an entity after marking it as
1166 -- statically allocated).
1168 and then not Is_Statically_Allocated
(Entity
(N
))
1170 Set_Is_Statically_Allocated
(Entity
(N
));
1176 procedure Fixup_Tree
is new Traverse_Proc
(Fixup_Node
);
1178 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1181 Fixup_Tree
(Aggregate
);
1182 end Force_Static_Allocation_Of_Referenced_Objects
;
1188 function Null_String
return String_Id
is
1191 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
1199 Flag_Id
: Entity_Id
;
1202 -- Start of processing for Expand_N_Exception_Declaration
1205 -- Nothing to do when generating C code
1207 if Modify_Tree_For_C
then
1211 -- Definition of the external name: nam : constant String := "A.B.NAME";
1214 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Id
), 'E'));
1216 -- Do not generate an external name if the exception declaration is
1217 -- subject to pragma Discard_Names. Use a null-terminated empty name
1218 -- to ensure that Ada.Exceptions.Exception_Name functions properly.
1220 if Global_Discard_Names
or else Discard_Names
(Ex_Id
) then
1221 Ex_Val
:= Null_String
;
1223 -- Otherwise generate the fully qualified name of the exception
1226 Ex_Val
:= Fully_Qualified_Name_String
(Id
);
1230 Make_Object_Declaration
(Loc
,
1231 Defining_Identifier
=> Ex_Id
,
1232 Constant_Present
=> True,
1233 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1234 Expression
=> Make_String_Literal
(Loc
, Ex_Val
)));
1236 Set_Is_Statically_Allocated
(Ex_Id
);
1238 -- Create the aggregate list for type Standard.Exception_Type:
1239 -- Handled_By_Other component: False
1242 Append_To
(L
, New_Occurrence_Of
(Standard_False
, Loc
));
1244 -- Lang component: 'A'
1247 Make_Character_Literal
(Loc
,
1249 Char_Literal_Value
=> UI_From_CC
(Get_Char_Code
('A'))));
1251 -- Name_Length component: Nam'Length
1254 Make_Attribute_Reference
(Loc
,
1255 Prefix
=> New_Occurrence_Of
(Ex_Id
, Loc
),
1256 Attribute_Name
=> Name_Length
));
1258 -- Full_Name component: Standard_Address?(Nam'Address)
1259 -- or 0 if CodePeer_Mode
1261 if CodePeer_Mode
then
1262 Append_To
(L
, Make_Integer_Literal
(Loc
, Uint_0
));
1264 Append_To
(L
, OK_Convert_To
(Standard_Address
,
1265 Make_Attribute_Reference
(Loc
,
1266 Prefix
=> New_Occurrence_Of
(Ex_Id
, Loc
),
1267 Attribute_Name
=> Name_Address
)));
1270 -- HTable_Ptr component: null
1272 Append_To
(L
, Make_Null
(Loc
));
1274 -- Foreign_Data component: null address
1276 Append_To
(L
, Make_Integer_Literal
(Loc
, Uint_0
));
1278 -- Raise_Hook component: null
1280 Append_To
(L
, Make_Null
(Loc
));
1282 Set_Expression
(N
, Make_Aggregate
(Loc
, Expressions
=> L
));
1283 Analyze_And_Resolve
(Expression
(N
), Etype
(Id
));
1285 Force_Static_Allocation_Of_Referenced_Objects
(Expression
(N
));
1287 -- Register_Exception (except'Unrestricted_Access);
1289 if not No_Exception_Handlers_Set
1290 and then not Restriction_Active
(No_Exception_Registration
)
1293 Make_Procedure_Call_Statement
(Loc
,
1295 New_Occurrence_Of
(RTE
(RE_Register_Exception
), Loc
),
1296 Parameter_Associations
=> New_List
(
1297 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
1298 Make_Attribute_Reference
(Loc
,
1299 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
1300 Attribute_Name
=> Name_Unrestricted_Access
)))));
1302 Set_Register_Exception_Call
(Id
, First
(L
));
1304 if not Is_Library_Level_Entity
(Id
) then
1306 Make_Defining_Identifier
(Loc
,
1307 Chars
=> New_External_Name
(Chars
(Id
), 'F'));
1308 Set_Is_Statically_Allocated
(Flag_Id
);
1311 Use_Test_And_Set_Flag
: constant Boolean :=
1312 (not Global_No_Tasking
)
1313 and then RTE_Available
(RE_Test_And_Set_Flag
);
1315 Flag_Decl
: Node_Id
;
1316 Condition
: Node_Id
;
1318 if Use_Test_And_Set_Flag
then
1320 Make_Object_Declaration
(Loc
,
1321 Defining_Identifier
=> Flag_Id
,
1322 Aliased_Present
=> True,
1323 Object_Definition
=>
1324 New_Occurrence_Of
(RTE
(RE_Test_And_Set_Flag
), Loc
));
1327 Make_Object_Declaration
(Loc
,
1328 Defining_Identifier
=> Flag_Id
,
1329 Object_Definition
=>
1330 New_Occurrence_Of
(Standard_Boolean
, Loc
),
1332 New_Occurrence_Of
(Standard_True
, Loc
));
1335 Insert_Action
(N
, Flag_Decl
);
1337 if Use_Test_And_Set_Flag
then
1340 Make_Function_Call
(Loc
,
1341 Name
=> New_Occurrence_Of
1342 (RTE
(RE_Atomic_Test_And_Set
), Loc
),
1343 Parameter_Associations
=>
1344 New_List
(New_Occurrence_Of
(Flag_Id
, Loc
))));
1346 Condition
:= New_Occurrence_Of
(Flag_Id
, Loc
);
1349 Make_Assignment_Statement
(Loc
,
1350 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1351 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1354 Insert_After_And_Analyze
(N
,
1355 Make_Implicit_If_Statement
(N
,
1356 Condition
=> Condition
,
1357 Then_Statements
=> L
));
1360 Insert_List_After_And_Analyze
(N
, L
);
1363 end Expand_N_Exception_Declaration
;
1365 ---------------------------------------------
1366 -- Expand_N_Handled_Sequence_Of_Statements --
1367 ---------------------------------------------
1369 procedure Expand_N_Handled_Sequence_Of_Statements
(N
: Node_Id
) is
1371 -- Expand exception handlers
1373 if Present
(Exception_Handlers
(N
))
1374 and then not Restriction_Active
(No_Exception_Handlers
)
1376 Expand_Exception_Handlers
(N
);
1379 -- If local exceptions are being expanded, the previous call will
1380 -- have rewritten the construct as a block and reanalyzed it. No
1381 -- further expansion is needed.
1383 if Analyzed
(N
) then
1387 -- Add cleanup actions if required. No cleanup actions are needed in
1388 -- thunks associated with interfaces, because they only displace the
1389 -- pointer to the object. For extended return statements, we need
1390 -- cleanup actions if the Handled_Statement_Sequence contains generated
1391 -- objects of controlled types, for example. We do not want to clean up
1392 -- the return object.
1394 if Nkind
(Parent
(N
)) not in N_Accept_Statement
1395 | N_Extended_Return_Statement
1397 and then not Delay_Cleanups
(Current_Scope
)
1398 and then not Is_Thunk
(Current_Scope
)
1400 Expand_Cleanup_Actions
(Parent
(N
));
1402 elsif Nkind
(Parent
(N
)) = N_Extended_Return_Statement
1403 and then Handled_Statement_Sequence
(Parent
(N
)) = N
1404 and then not Delay_Cleanups
(Current_Scope
)
1406 pragma Assert
(not Is_Thunk
(Current_Scope
));
1407 Expand_Cleanup_Actions
(Parent
(N
));
1410 Set_First_Real_Statement
(N
, First
(Statements
(N
)));
1412 end Expand_N_Handled_Sequence_Of_Statements
;
1414 -------------------------------------
1415 -- Expand_N_Raise_Constraint_Error --
1416 -------------------------------------
1418 procedure Expand_N_Raise_Constraint_Error
(N
: Node_Id
) is
1420 -- We adjust the condition to deal with the C/Fortran boolean case. This
1421 -- may well not be necessary, as all such conditions are generated by
1422 -- the expander and probably are all standard boolean, but who knows
1423 -- what strange optimization in future may require this adjustment.
1425 Adjust_Condition
(Condition
(N
));
1427 -- Now deal with possible local raise handling
1429 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1430 end Expand_N_Raise_Constraint_Error
;
1432 -------------------------------
1433 -- Expand_N_Raise_Expression --
1434 -------------------------------
1436 procedure Expand_N_Raise_Expression
(N
: Node_Id
) is
1437 Loc
: constant Source_Ptr
:= Sloc
(N
);
1438 Typ
: constant Entity_Id
:= Etype
(N
);
1442 Possible_Local_Raise
(N
, Entity
(Name
(N
)));
1444 -- Later we must teach the back end/gigi how to deal with this, but
1445 -- for now we will assume the type is Standard_Boolean and transform
1449 -- raise X [with string]
1451 -- raise Constraint_Error;
1453 -- unless the flag Convert_To_Return_False is set, in which case
1454 -- the transformation is to:
1459 -- raise Constraint_Error;
1461 -- The raise constraint error can never be executed. It is just a dummy
1462 -- node that can be labeled with an arbitrary type.
1464 RCE
:= Make_Raise_Constraint_Error
(Loc
, Reason
=> CE_Explicit_Raise
);
1465 Set_Etype
(RCE
, Typ
);
1467 if Convert_To_Return_False
(N
) then
1469 Make_Expression_With_Actions
(Loc
,
1470 Actions
=> New_List
(
1471 Make_Simple_Return_Statement
(Loc
,
1472 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
1473 Expression
=> RCE
));
1477 Make_Expression_With_Actions
(Loc
,
1478 Actions
=> New_List
(
1479 Make_Raise_Statement
(Loc
,
1481 Expression
=> Expression
(N
))),
1482 Expression
=> RCE
));
1485 Analyze_And_Resolve
(N
, Typ
);
1486 end Expand_N_Raise_Expression
;
1488 ----------------------------------
1489 -- Expand_N_Raise_Program_Error --
1490 ----------------------------------
1492 procedure Expand_N_Raise_Program_Error
(N
: Node_Id
) is
1494 -- We adjust the condition to deal with the C/Fortran boolean case. This
1495 -- may well not be necessary, as all such conditions are generated by
1496 -- the expander and probably are all standard boolean, but who knows
1497 -- what strange optimization in future may require this adjustment.
1499 Adjust_Condition
(Condition
(N
));
1501 -- Now deal with possible local raise handling
1503 Possible_Local_Raise
(N
, Standard_Program_Error
);
1504 end Expand_N_Raise_Program_Error
;
1506 ------------------------------
1507 -- Expand_N_Raise_Statement --
1508 ------------------------------
1510 procedure Expand_N_Raise_Statement
(N
: Node_Id
) is
1511 Loc
: constant Source_Ptr
:= Sloc
(N
);
1519 -- Processing for locally handled exception (exclude reraise case)
1521 if Present
(Name
(N
)) and then Is_Entity_Name
(Name
(N
)) then
1523 or else Restriction_Active
(No_Exception_Propagation
)
1525 -- If we have a local handler, then note that this is potentially
1526 -- able to be transformed into a goto statement.
1528 H
:= Find_Local_Handler
(Entity
(Name
(N
)), N
);
1531 if Local_Raise_Statements
(H
) = No_Elist
then
1532 Set_Local_Raise_Statements
(H
, New_Elmt_List
);
1535 -- Append the new entry if it is not there already. Sometimes
1536 -- we have situations where due to reexpansion, the same node
1537 -- is analyzed twice and would otherwise be added twice.
1539 Append_Unique_Elmt
(N
, Local_Raise_Statements
(H
));
1540 Set_Has_Local_Raise
(H
);
1542 -- If no local handler, then generate no propagation warning
1545 Warn_If_No_Propagation
(N
);
1551 -- If a string expression is present, then the raise statement is
1552 -- converted to a call:
1553 -- Raise_Exception (exception-name'Identity, string);
1554 -- and there is nothing else to do.
1556 if Present
(Expression
(N
)) then
1558 -- Adjust message to deal with Prefix_Exception_Messages. We only
1559 -- add the prefix to string literals, if the message is being
1560 -- constructed, we assume it already deals with uniqueness.
1562 if Prefix_Exception_Messages
1563 and then Nkind
(Expression
(N
)) = N_String_Literal
1566 Buf
: Bounded_String
;
1568 Add_Source_Info
(Buf
, Loc
, Name_Enclosing_Entity
);
1570 Append
(Buf
, Strval
(Expression
(N
)));
1571 Rewrite
(Expression
(N
), Make_String_Literal
(Loc
, +Buf
));
1572 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
1576 -- Avoid passing exception-name'identity in runtimes in which this
1577 -- argument is not used. This avoids generating undefined references
1578 -- to these exceptions when compiling with no optimization
1580 if Configurable_Run_Time_On_Target
1581 and then (Restriction_Active
(No_Exception_Handlers
)
1583 Restriction_Active
(No_Exception_Propagation
))
1586 Make_Procedure_Call_Statement
(Loc
,
1587 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1588 Parameter_Associations
=> New_List
(
1589 New_Occurrence_Of
(RTE
(RE_Null_Id
), Loc
),
1593 Make_Procedure_Call_Statement
(Loc
,
1594 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1595 Parameter_Associations
=> New_List
(
1596 Make_Attribute_Reference
(Loc
,
1598 Attribute_Name
=> Name_Identity
),
1606 -- Remaining processing is for the case where no string expression is
1609 -- Don't expand a raise statement that does not come from source if we
1610 -- have already had configurable run-time violations, since most likely
1611 -- it will be junk cascaded nonsense.
1613 if Configurable_Run_Time_Violations
> 0
1614 and then not Comes_From_Source
(N
)
1619 -- Convert explicit raise of Program_Error, Constraint_Error, and
1620 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1621 -- all other raises will get normal expansion and be disallowed,
1622 -- but this is also faster in all modes). Propagate Comes_From_Source
1623 -- flag to the new node.
1625 if Present
(Name
(N
)) and then Is_Entity_Name
(Name
(N
)) then
1626 Src
:= Comes_From_Source
(N
);
1628 if Entity
(Name
(N
)) = Standard_Constraint_Error
then
1630 Make_Raise_Constraint_Error
(Loc
, Reason
=> CE_Explicit_Raise
));
1631 Set_Comes_From_Source
(N
, Src
);
1635 elsif Entity
(Name
(N
)) = Standard_Program_Error
then
1637 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1638 Set_Comes_From_Source
(N
, Src
);
1642 elsif Entity
(Name
(N
)) = Standard_Storage_Error
then
1644 Make_Raise_Storage_Error
(Loc
, Reason
=> SE_Explicit_Raise
));
1645 Set_Comes_From_Source
(N
, Src
);
1651 -- Case of name present, in this case we expand raise name to
1653 -- Raise_Exception (name'Identity, location_string);
1655 -- where location_string identifies the file/line of the raise
1657 if Present
(Name
(N
)) and then Is_Entity_Name
(Name
(N
)) then
1659 Id
: Entity_Id
:= Entity
(Name
(N
));
1660 Buf
: Bounded_String
;
1663 Build_Location_String
(Buf
, Loc
);
1665 -- If the exception is a renaming, use the exception that it
1666 -- renames (which might be a predefined exception, e.g.).
1668 if Present
(Renamed_Entity
(Id
)) then
1669 Id
:= Renamed_Entity
(Id
);
1672 -- Build a C-compatible string in case of no exception handlers,
1673 -- since this is what the last chance handler is expecting.
1675 if No_Exception_Handlers_Set
then
1677 -- Generate an empty message if configuration pragma
1678 -- Suppress_Exception_Locations is set for this unit.
1680 if Opt
.Exception_Locations_Suppressed
then
1684 Append
(Buf
, ASCII
.NUL
);
1687 if Opt
.Exception_Locations_Suppressed
then
1691 Str
:= String_From_Name_Buffer
(Buf
);
1693 -- Convert raise to call to the Raise_Exception routine
1696 Make_Procedure_Call_Statement
(Loc
,
1698 New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1699 Parameter_Associations
=> New_List
(
1700 Make_Attribute_Reference
(Loc
,
1702 Attribute_Name
=> Name_Identity
),
1703 Make_String_Literal
(Loc
, Strval
=> Str
))));
1706 -- Case of no name present (reraise). We rewrite the raise to:
1708 -- Reraise_Occurrence_Always (EO);
1710 -- where EO is the current exception occurrence. If the current handler
1711 -- does not have a choice parameter specification, then we provide one.
1714 -- Bypass expansion to a run-time call when back-end exception
1715 -- handling is active, unless the target is CodePeer or GNATprove.
1716 -- In CodePeer, raising an exception is treated as an error, while in
1717 -- GNATprove all code with exceptions falls outside the subset of
1718 -- code which can be formally analyzed.
1720 if not CodePeer_Mode
1721 and then Back_End_Exceptions
1726 -- Find innermost enclosing exception handler (there must be one,
1727 -- since the semantics has already verified that this raise statement
1728 -- is valid, and a raise with no arguments is only permitted in the
1729 -- context of an exception handler.
1731 Ehand
:= Parent
(N
);
1732 while Nkind
(Ehand
) /= N_Exception_Handler
loop
1733 Ehand
:= Parent
(Ehand
);
1736 -- Make exception choice parameter if none present. Note that we do
1737 -- not need to put the entity on the entity chain, since no one will
1738 -- be referencing this entity by normal visibility methods.
1740 if No
(Choice_Parameter
(Ehand
)) then
1741 E
:= Make_Temporary
(Loc
, 'E');
1742 Set_Choice_Parameter
(Ehand
, E
);
1743 Mutate_Ekind
(E
, E_Variable
);
1744 Set_Etype
(E
, RTE
(RE_Exception_Occurrence
));
1745 Set_Scope
(E
, Current_Scope
);
1748 -- Now rewrite the raise as a call to Reraise. A special case arises
1749 -- if this raise statement occurs in the context of a handler for
1750 -- all others (i.e. an at end handler). in this case we avoid
1751 -- the call to defer abort, cleanup routines are expected to be
1752 -- called in this case with aborts deferred.
1755 Ech
: constant Node_Id
:= First
(Exception_Choices
(Ehand
));
1759 if Nkind
(Ech
) = N_Others_Choice
1760 and then All_Others
(Ech
)
1762 Ent
:= RTE
(RE_Reraise_Occurrence_No_Defer
);
1764 Ent
:= RTE
(RE_Reraise_Occurrence_Always
);
1768 Make_Procedure_Call_Statement
(Loc
,
1769 Name
=> New_Occurrence_Of
(Ent
, Loc
),
1770 Parameter_Associations
=> New_List
(
1771 New_Occurrence_Of
(Choice_Parameter
(Ehand
), Loc
))));
1776 end Expand_N_Raise_Statement
;
1778 -----------------------------------
1779 -- Expand_N_Raise_When_Statement --
1780 -----------------------------------
1782 procedure Expand_N_Raise_When_Statement
(N
: Node_Id
) is
1783 Loc
: constant Source_Ptr
:= Sloc
(N
);
1786 Make_If_Statement
(Loc
,
1787 Condition
=> Condition
(N
),
1788 Then_Statements
=> New_List
(
1789 Make_Raise_Statement
(Loc
,
1791 Expression
=> Expression
(N
)))));
1794 end Expand_N_Raise_When_Statement
;
1796 ----------------------------------
1797 -- Expand_N_Raise_Storage_Error --
1798 ----------------------------------
1800 procedure Expand_N_Raise_Storage_Error
(N
: Node_Id
) is
1802 -- We adjust the condition to deal with the C/Fortran boolean case. This
1803 -- may well not be necessary, as all such conditions are generated by
1804 -- the expander and probably are all standard boolean, but who knows
1805 -- what strange optimization in future may require this adjustment.
1807 Adjust_Condition
(Condition
(N
));
1809 -- Now deal with possible local raise handling
1811 Possible_Local_Raise
(N
, Standard_Storage_Error
);
1812 end Expand_N_Raise_Storage_Error
;
1814 --------------------------
1815 -- Possible_Local_Raise --
1816 --------------------------
1818 procedure Possible_Local_Raise
(N
: Node_Id
; E
: Entity_Id
) is
1820 -- Nothing to do if local raise optimization not active
1822 if not Debug_Flag_Dot_G
1823 and then not Restriction_Active
(No_Exception_Propagation
)
1828 -- Nothing to do if original node was an explicit raise, because in
1829 -- that case, we already generated the required warning for the raise.
1831 if Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
1835 -- Otherwise see if we have a local handler for the exception
1838 H
: constant Node_Id
:= Find_Local_Handler
(E
, N
);
1841 -- If so, mark that it has a local raise
1844 Set_Has_Local_Raise
(H
, True);
1846 -- Otherwise, if the No_Exception_Propagation restriction is active
1847 -- and the warning is enabled, generate the appropriate warnings.
1849 -- ??? Do not do it for the Call_Marker nodes inserted by the ABE
1850 -- mechanism because this generates too many false positives, or
1851 -- for generic instantiations for the same reason.
1853 elsif Warn_On_Non_Local_Exception
1854 and then Restriction_Active
(No_Exception_Propagation
)
1855 and then Nkind
(N
) /= N_Call_Marker
1856 and then Nkind
(N
) not in N_Generic_Instantiation
1858 Warn_No_Exception_Propagation_Active
(N
);
1860 if Configurable_Run_Time_Mode
then
1862 ("\?.x?& may call Last_Chance_Handler", N
, E
);
1865 ("\?.x?& may result in unhandled exception", N
, E
);
1869 end Possible_Local_Raise
;
1871 ------------------------
1872 -- Find_Local_Handler --
1873 ------------------------
1875 function Find_Local_Handler
1877 Nod
: Node_Id
) return Node_Id
1884 SSE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
1885 -- This is used to test for wrapped actions below
1888 EHandle
: Entity_Id
;
1889 -- The entity Id's for the exception we are raising and handling, using
1890 -- the renamed exception if a Renamed_Entity is present.
1893 -- Never any local handler if all handlers removed
1895 if Debug_Flag_Dot_X
then
1899 -- Get the exception we are raising, allowing for renaming
1901 ERaise
:= Get_Renamed_Entity
(Ename
);
1903 -- We need to check if the node we are looking at is contained in
1906 -- Loop to search up the tree
1912 -- If we get to the top of the tree, or to a subprogram, task, entry,
1913 -- protected body, or accept statement without having found a
1914 -- matching handler, then there is no local handler.
1917 or else Nkind
(P
) = N_Subprogram_Body
1918 or else Nkind
(P
) = N_Task_Body
1919 or else Nkind
(P
) = N_Protected_Body
1920 or else Nkind
(P
) = N_Entry_Body
1921 or else Nkind
(P
) = N_Accept_Statement
1925 -- Test for handled sequence of statements with at least one
1926 -- exception handler which might be the one we are looking for.
1928 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
1929 and then Present
(Exception_Handlers
(P
))
1931 -- Before we proceed we need to check if the node N is covered
1932 -- by the statement part of P rather than one of its exception
1933 -- handlers (an exception handler obviously does not cover its
1936 -- This test is more delicate than might be thought. It is not
1937 -- just a matter of checking the Statements (P), because the node
1938 -- might be waiting to be wrapped in a transient scope, in which
1939 -- case it will end up in the block statements, even though it
1940 -- is not there now.
1942 if Is_List_Member
(N
) then
1944 LCN
: constant List_Id
:= List_Containing
(N
);
1947 if LCN
= Statements
(P
)
1949 LCN
= SSE
.Actions_To_Be_Wrapped
(Before
)
1951 LCN
= SSE
.Actions_To_Be_Wrapped
(After
)
1953 LCN
= SSE
.Actions_To_Be_Wrapped
(Cleanup
)
1955 -- Loop through exception handlers
1957 H
:= First
(Exception_Handlers
(P
));
1958 while Present
(H
) loop
1960 -- Guard against other constructs appearing in the
1961 -- list of exception handlers.
1963 if Nkind
(H
) = N_Exception_Handler
then
1965 -- Loop through choices in one handler
1967 C
:= First
(Exception_Choices
(H
));
1968 while Present
(C
) loop
1970 -- Deal with others case
1972 if Nkind
(C
) = N_Others_Choice
then
1974 -- Matching others handler, but we need
1975 -- to ensure there is no choice parameter.
1976 -- If there is, then we don't have a local
1977 -- handler after all (since we do not allow
1978 -- choice parameters for local handlers).
1980 if No
(Choice_Parameter
(H
)) then
1986 -- If not others must be entity name
1988 elsif Nkind
(C
) /= N_Others_Choice
then
1989 pragma Assert
(Is_Entity_Name
(C
));
1990 pragma Assert
(Present
(Entity
(C
)));
1992 -- Get exception being handled, dealing with
1995 EHandle
:= Get_Renamed_Entity
(Entity
(C
));
1997 -- If match, then check choice parameter
1999 if ERaise
= EHandle
then
2000 if No
(Choice_Parameter
(H
)) then
2021 end Find_Local_Handler
;
2023 ---------------------------------
2024 -- Get_Local_Raise_Call_Entity --
2025 ---------------------------------
2027 -- Note: this is primarily provided for use by the back end in generating
2028 -- calls to Local_Raise. But it would be too late in the back end to call
2029 -- RTE if this actually caused a load/analyze of the unit. So what we do
2030 -- is to ensure there is a dummy call to this function during front end
2031 -- processing so that the unit gets loaded then, and not later.
2033 Local_Raise_Call_Entity
: Entity_Id
;
2034 Local_Raise_Call_Entity_Set
: Boolean := False;
2036 function Get_Local_Raise_Call_Entity
return Entity_Id
is
2038 if not Local_Raise_Call_Entity_Set
then
2039 Local_Raise_Call_Entity_Set
:= True;
2041 if RTE_Available
(RE_Local_Raise
) then
2042 Local_Raise_Call_Entity
:= RTE
(RE_Local_Raise
);
2044 Local_Raise_Call_Entity
:= Empty
;
2048 return Local_Raise_Call_Entity
;
2049 end Get_Local_Raise_Call_Entity
;
2051 -----------------------------
2052 -- Get_RT_Exception_Entity --
2053 -----------------------------
2055 function Get_RT_Exception_Entity
(R
: RT_Exception_Code
) return Entity_Id
is
2058 when CE_Reason
=> return Standard_Constraint_Error
;
2059 when PE_Reason
=> return Standard_Program_Error
;
2060 when SE_Reason
=> return Standard_Storage_Error
;
2062 end Get_RT_Exception_Entity
;
2064 ---------------------------
2065 -- Get_RT_Exception_Name --
2066 ---------------------------
2068 procedure Get_RT_Exception_Name
(Code
: RT_Exception_Code
) is
2071 when CE_Access_Check_Failed
=>
2072 Add_Str_To_Name_Buffer
("CE_Access_Check");
2073 when CE_Access_Parameter_Is_Null
=>
2074 Add_Str_To_Name_Buffer
("CE_Null_Access_Parameter");
2075 when CE_Discriminant_Check_Failed
=>
2076 Add_Str_To_Name_Buffer
("CE_Discriminant_Check");
2077 when CE_Divide_By_Zero
=>
2078 Add_Str_To_Name_Buffer
("CE_Divide_By_Zero");
2079 when CE_Explicit_Raise
=>
2080 Add_Str_To_Name_Buffer
("CE_Explicit_Raise");
2081 when CE_Index_Check_Failed
=>
2082 Add_Str_To_Name_Buffer
("CE_Index_Check");
2083 when CE_Invalid_Data
=>
2084 Add_Str_To_Name_Buffer
("CE_Invalid_Data");
2085 when CE_Length_Check_Failed
=>
2086 Add_Str_To_Name_Buffer
("CE_Length_Check");
2087 when CE_Null_Exception_Id
=>
2088 Add_Str_To_Name_Buffer
("CE_Null_Exception_Id");
2089 when CE_Null_Not_Allowed
=>
2090 Add_Str_To_Name_Buffer
("CE_Null_Not_Allowed");
2091 when CE_Overflow_Check_Failed
=>
2092 Add_Str_To_Name_Buffer
("CE_Overflow_Check");
2093 when CE_Partition_Check_Failed
=>
2094 Add_Str_To_Name_Buffer
("CE_Partition_Check");
2095 when CE_Range_Check_Failed
=>
2096 Add_Str_To_Name_Buffer
("CE_Range_Check");
2097 when CE_Tag_Check_Failed
=>
2098 Add_Str_To_Name_Buffer
("CE_Tag_Check");
2100 when PE_Access_Before_Elaboration
=>
2101 Add_Str_To_Name_Buffer
("PE_Access_Before_Elaboration");
2102 when PE_Accessibility_Check_Failed
=>
2103 Add_Str_To_Name_Buffer
("PE_Accessibility_Check");
2104 when PE_Address_Of_Intrinsic
=>
2105 Add_Str_To_Name_Buffer
("PE_Address_Of_Intrinsic");
2106 when PE_Aliased_Parameters
=>
2107 Add_Str_To_Name_Buffer
("PE_Aliased_Parameters");
2108 when PE_All_Guards_Closed
=>
2109 Add_Str_To_Name_Buffer
("PE_All_Guards_Closed");
2110 when PE_Bad_Predicated_Generic_Type
=>
2111 Add_Str_To_Name_Buffer
("PE_Bad_Predicated_Generic_Type");
2112 when PE_Build_In_Place_Mismatch
=>
2113 Add_Str_To_Name_Buffer
("PE_Build_In_Place_Mismatch");
2114 when PE_Current_Task_In_Entry_Body
=>
2115 Add_Str_To_Name_Buffer
("PE_Current_Task_In_Entry_Body");
2116 when PE_Duplicated_Entry_Address
=>
2117 Add_Str_To_Name_Buffer
("PE_Duplicated_Entry_Address");
2118 when PE_Explicit_Raise
=>
2119 Add_Str_To_Name_Buffer
("PE_Explicit_Raise");
2120 when PE_Finalize_Raised_Exception
=>
2121 Add_Str_To_Name_Buffer
("PE_Finalize_Raised_Exception");
2122 when PE_Implicit_Return
=>
2123 Add_Str_To_Name_Buffer
("PE_Implicit_Return");
2124 when PE_Misaligned_Address_Value
=>
2125 Add_Str_To_Name_Buffer
("PE_Misaligned_Address_Value");
2126 when PE_Missing_Return
=>
2127 Add_Str_To_Name_Buffer
("PE_Missing_Return");
2128 when PE_Non_Transportable_Actual
=>
2129 Add_Str_To_Name_Buffer
("PE_Non_Transportable_Actual");
2130 when PE_Overlaid_Controlled_Object
=>
2131 Add_Str_To_Name_Buffer
("PE_Overlaid_Controlled_Object");
2132 when PE_Potentially_Blocking_Operation
=>
2133 Add_Str_To_Name_Buffer
("PE_Potentially_Blocking_Operation");
2134 when PE_Stream_Operation_Not_Allowed
=>
2135 Add_Str_To_Name_Buffer
("PE_Stream_Operation_Not_Allowed");
2136 when PE_Stubbed_Subprogram_Called
=>
2137 Add_Str_To_Name_Buffer
("PE_Stubbed_Subprogram_Called");
2138 when PE_Unchecked_Union_Restriction
=>
2139 Add_Str_To_Name_Buffer
("PE_Unchecked_Union_Restriction");
2141 when SE_Empty_Storage_Pool
=>
2142 Add_Str_To_Name_Buffer
("SE_Empty_Storage_Pool");
2143 when SE_Explicit_Raise
=>
2144 Add_Str_To_Name_Buffer
("SE_Explicit_Raise");
2145 when SE_Infinite_Recursion
=>
2146 Add_Str_To_Name_Buffer
("SE_Infinite_Recursion");
2147 when SE_Object_Too_Large
=>
2148 Add_Str_To_Name_Buffer
("SE_Object_Too_Large");
2150 end Get_RT_Exception_Name
;
2152 ----------------------------
2153 -- Warn_If_No_Local_Raise --
2154 ----------------------------
2156 procedure Warn_If_No_Local_Raise
(N
: Node_Id
) is
2158 if Restriction_Active
(No_Exception_Propagation
)
2159 and then Warn_On_Non_Local_Exception
2161 Warn_No_Exception_Propagation_Active
(N
);
2164 ("\?.x?this handler can never be entered, and has been removed", N
);
2166 end Warn_If_No_Local_Raise
;
2168 ----------------------------
2169 -- Warn_If_No_Propagation --
2170 ----------------------------
2172 procedure Warn_If_No_Propagation
(N
: Node_Id
) is
2174 if Restriction_Check_Required
(No_Exception_Propagation
)
2175 and then Warn_On_Non_Local_Exception
2177 Warn_No_Exception_Propagation_Active
(N
);
2179 if Configurable_Run_Time_Mode
then
2181 ("\?.x?Last_Chance_Handler will be called on exception", N
);
2184 ("\?.x?execution may raise unhandled exception", N
);
2187 end Warn_If_No_Propagation
;
2189 ------------------------------------------
2190 -- Warn_No_Exception_Propagation_Active --
2191 ------------------------------------------
2193 procedure Warn_No_Exception_Propagation_Active
(N
: Node_Id
) is
2196 ("?.x?pragma Restrictions (No_Exception_Propagation) in effect", N
);
2197 end Warn_No_Exception_Propagation_Active
;