1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 if Present (Choice_Parameter (Handler)) then
1030 Cparm : constant Entity_Id := Choice_Parameter (Handler);
1031 Cloc : constant Source_Ptr := Sloc (Cparm);
1032 Hloc : constant Source_Ptr := Sloc (Handler);
1036 -- Note use of No_Location to hide this code from the
1037 -- debugger, so single stepping doesn't jump back and
1041 Make_Procedure_Call_Statement (No_Location,
1044 (RTE (RE_Save_Occurrence), No_Location),
1045 Parameter_Associations => New_List (
1046 New_Occurrence_Of (Cparm, No_Location),
1047 Make_Explicit_Dereference (No_Location,
1048 Make_Function_Call (No_Location,
1050 Make_Explicit_Dereference (No_Location,
1052 (RTE (RE_Get_Current_Excep),
1055 Mark_Rewrite_Insertion (Save);
1056 Prepend (Save, Statements (Handler));
1059 Make_Object_Declaration
1061 Defining_Identifier => Cparm,
1062 Object_Definition =>
1064 (RTE (RE_Exception_Occurrence), Cloc));
1065 Set_No_Initialization (Obj_Decl, True);
1068 Make_Exception_Handler (Hloc,
1069 Choice_Parameter => Empty,
1070 Exception_Choices => Exception_Choices (Handler),
1072 Statements => New_List (
1073 Make_Block_Statement (Hloc,
1074 Declarations => New_List (Obj_Decl),
1075 Handled_Statement_Sequence =>
1076 Make_Handled_Sequence_Of_Statements (Hloc,
1077 Statements => Statements (Handler))))));
1079 -- Local raise statements can't occur, since exception
1080 -- handlers with choice parameters are not allowed when
1081 -- No_Exception_Propagation applies, so set attributes
1084 Set_Local_Raise_Statements (Handler, No_Elist);
1085 Set_Local_Raise_Not_OK (Handler);
1088 (Statements (Handler), Suppress => All_Checks);
1092 -- The processing at this point is rather different for the JVM
1093 -- case, so we completely separate the processing.
1095 -- For the VM case, we unconditionally call Update_Exception,
1096 -- passing a call to the intrinsic Current_Target_Exception
1097 -- (see JVM/.NET versions of Ada.Exceptions for details).
1099 if VM_Target /= No_VM then
1101 Arg : constant Node_Id :=
1102 Make_Function_Call (Loc,
1105 (RTE (RE_Current_Target_Exception), Loc));
1107 Prepend_Call_To_Handler
1108 (RE_Update_Exception, New_List (Arg));
1111 -- For the normal case, we have to worry about the state of
1112 -- abort deferral. Generally, we defer abort during runtime
1113 -- handling of exceptions. When control is passed to the
1114 -- handler, then in the normal case we undefer aborts. In
1115 -- any case this entire handling is relevant only if aborts
1119 and then Exception_Mechanism /= Back_End_Exceptions
1121 -- There are some special cases in which we do not do the
1122 -- undefer. In particular a finalization (AT END) handler
1123 -- wants to operate with aborts still deferred.
1125 -- We also suppress the call if this is the special handler
1126 -- for Abort_Signal, since if we are aborting, we want to
1127 -- keep aborts deferred (one abort is enough).
1129 -- If abort really needs to be deferred the expander must
1130 -- add this call explicitly, see
1131 -- Expand_N_Asynchronous_Select.
1134 Nkind (First (Exception_Choices (Handler))) =
1138 or else Entity (First (Exception_Choices (Handler))) /=
1143 All_Others (First (Exception_Choices (Handler))))
1145 Prepend_Call_To_Handler (RE_Abort_Undefer);
1151 Handler := Next_Handler;
1152 end loop Handler_Loop;
1154 -- If all handlers got removed, then remove the list. Note we cannot
1155 -- reference HSS here, since expanding local handlers may have buried
1156 -- the handlers in an inner block.
1158 if Is_Empty_List (Handlrs) then
1159 Set_Exception_Handlers (Parent (Handlrs), No_List);
1161 end Expand_Exception_Handlers;
1163 ------------------------------------
1164 -- Expand_N_Exception_Declaration --
1165 ------------------------------------
1168 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1169 -- except : exception_data := (
1170 -- Handled_By_Other => False,
1172 -- Name_Length => exceptE'Length,
1173 -- Full_Name => exceptE'Address,
1174 -- HTable_Ptr => null,
1175 -- Import_Code => 0,
1176 -- Raise_Hook => null,
1179 -- (protecting test only needed if not at library level)
1181 -- exceptF : Boolean := True -- static data
1183 -- exceptF := False;
1184 -- Register_Exception (except'Unchecked_Access);
1187 procedure Expand_N_Exception_Declaration (N : Node_Id) is
1188 Loc : constant Source_Ptr := Sloc (N);
1189 Id : constant Entity_Id := Defining_Identifier (N);
1190 L : List_Id := New_List;
1191 Flag_Id : Entity_Id;
1193 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1194 Exname : constant Node_Id :=
1195 Make_Defining_Identifier (Loc, Name_Exname);
1197 procedure Force_Static_Allocation_Of_Referenced_Objects
1198 (Aggregate : Node_Id);
1199 -- A specialized solution to one particular case of an ugly problem
1201 -- The given aggregate includes an Unchecked_Conversion as one of the
1202 -- component values. The call to Analyze_And_Resolve below ends up
1203 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1204 -- to introduce a (constant) temporary and then obtain the component
1205 -- value by evaluating the temporary.
1207 -- In the case of an exception declared within a subprogram (or any
1208 -- other dynamic scope), this is a bad transformation. The exception
1209 -- object is marked as being Statically_Allocated but the temporary is
1210 -- not. If the initial value of a Statically_Allocated declaration
1211 -- references a dynamically allocated object, this prevents static
1212 -- initialization of the object.
1214 -- We cope with this here by marking the temporary Statically_Allocated.
1215 -- It might seem cleaner to generalize this utility and then use it to
1216 -- enforce a rule that the entities referenced in the declaration of any
1217 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1218 -- entity must also be either Library_Level or hoisted. It turns out
1219 -- that this would be incompatible with the current treatment of an
1220 -- object which is local to a subprogram, subject to an Export pragma,
1221 -- not subject to an address clause, and whose declaration contains
1222 -- references to other local (non-hoisted) objects (e.g., in the initial
1223 -- value expression).
1225 ---------------------------------------------------
1226 -- Force_Static_Allocation_Of_Referenced_Objects --
1227 ---------------------------------------------------
1229 procedure Force_Static_Allocation_Of_Referenced_Objects
1230 (Aggregate : Node_Id)
1232 function Fixup_Node (N : Node_Id) return Traverse_Result;
1233 -- If the given node references a dynamically allocated object, then
1234 -- correct the declaration of the object.
1240 function Fixup_Node (N : Node_Id) return Traverse_Result is
1242 if Nkind (N) in N_Has_Entity
1243 and then Present (Entity (N))
1244 and then not Is_Library_Level_Entity (Entity (N))
1246 -- Note: the following test is not needed but it seems cleaner
1247 -- to do this test (this would be more important if procedure
1248 -- Force_Static_Allocation_Of_Referenced_Objects recursively
1249 -- traversed the declaration of an entity after marking it as
1250 -- statically allocated).
1252 and then not Is_Statically_Allocated (Entity (N))
1254 Set_Is_Statically_Allocated (Entity (N));
1260 procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
1262 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1265 Fixup_Tree (Aggregate);
1266 end Force_Static_Allocation_Of_Referenced_Objects;
1268 -- Start of processing for Expand_N_Exception_Declaration
1271 -- There is no expansion needed when compiling for the JVM since the
1272 -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
1275 if VM_Target /= No_VM then
1279 -- Definition of the external name: nam : constant String := "A.B.NAME";
1282 Make_Object_Declaration (Loc,
1283 Defining_Identifier => Exname,
1284 Constant_Present => True,
1285 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1287 Make_String_Literal (Loc,
1288 Strval => Fully_Qualified_Name_String (Id))));
1290 Set_Is_Statically_Allocated (Exname);
1292 -- Create the aggregate list for type Standard.Exception_Type:
1293 -- Handled_By_Other component: False
1295 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1297 -- Lang component: 'A'
1300 Make_Character_Literal (Loc,
1302 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
1304 -- Name_Length component: Nam'Length
1307 Make_Attribute_Reference (Loc,
1308 Prefix => New_Occurrence_Of (Exname, Loc),
1309 Attribute_Name => Name_Length));
1311 -- Full_Name component: Standard.A_Char!(Nam'Address)
1313 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1314 Make_Attribute_Reference (Loc,
1315 Prefix => New_Occurrence_Of (Exname, Loc),
1316 Attribute_Name => Name_Address)));
1318 -- HTable_Ptr component: null
1320 Append_To (L, Make_Null (Loc));
1322 -- Import_Code component: 0
1324 Append_To (L, Make_Integer_Literal (Loc, 0));
1326 -- Raise_Hook component: null
1328 Append_To (L, Make_Null (Loc));
1330 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1331 Analyze_And_Resolve (Expression (N), Etype (Id));
1333 Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
1335 -- Register_Exception (except'Unchecked_Access);
1337 if not No_Exception_Handlers_Set
1338 and then not Restriction_Active (No_Exception_Registration)
1341 Make_Procedure_Call_Statement (Loc,
1342 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1343 Parameter_Associations => New_List (
1344 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1345 Make_Attribute_Reference (Loc,
1346 Prefix => New_Occurrence_Of (Id, Loc),
1347 Attribute_Name => Name_Unrestricted_Access)))));
1349 Set_Register_Exception_Call (Id, First (L));
1351 if not Is_Library_Level_Entity (Id) then
1352 Flag_Id := Make_Defining_Identifier (Loc,
1353 New_External_Name (Chars (Id), 'F'));
1356 Make_Object_Declaration (Loc,
1357 Defining_Identifier => Flag_Id,
1358 Object_Definition =>
1359 New_Occurrence_Of (Standard_Boolean, Loc),
1361 New_Occurrence_Of (Standard_True, Loc)));
1363 Set_Is_Statically_Allocated (Flag_Id);
1366 Make_Assignment_Statement (Loc,
1367 Name => New_Occurrence_Of (Flag_Id, Loc),
1368 Expression => New_Occurrence_Of (Standard_False, Loc)));
1370 Insert_After_And_Analyze (N,
1371 Make_Implicit_If_Statement (N,
1372 Condition => New_Occurrence_Of (Flag_Id, Loc),
1373 Then_Statements => L));
1376 Insert_List_After_And_Analyze (N, L);
1379 end Expand_N_Exception_Declaration;
1381 ---------------------------------------------
1382 -- Expand_N_Handled_Sequence_Of_Statements --
1383 ---------------------------------------------
1385 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1387 -- Expand exception handlers
1389 if Present (Exception_Handlers (N))
1390 and then not Restriction_Active (No_Exception_Handlers)
1392 Expand_Exception_Handlers (N);
1395 -- If local exceptions are being expanded, the previous call will
1396 -- have rewritten the construct as a block and reanalyzed it. No
1397 -- further expansion is needed.
1399 if Analyzed (N) then
1403 -- Add clean up actions if required
1405 if Nkind (Parent (N)) /= N_Package_Body
1406 and then Nkind (Parent (N)) /= N_Accept_Statement
1407 and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1408 and then not Delay_Cleanups (Current_Scope)
1410 Expand_Cleanup_Actions (Parent (N));
1412 Set_First_Real_Statement (N, First (Statements (N)));
1414 end Expand_N_Handled_Sequence_Of_Statements;
1416 -------------------------------------
1417 -- Expand_N_Raise_Constraint_Error --
1418 -------------------------------------
1420 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1422 -- We adjust the condition to deal with the C/Fortran boolean case. This
1423 -- may well not be necessary, as all such conditions are generated by
1424 -- the expander and probably are all standard boolean, but who knows
1425 -- what strange optimization in future may require this adjustment!
1427 Adjust_Condition (Condition (N));
1429 -- Now deal with possible local raise handling
1431 Possible_Local_Raise (N, Standard_Constraint_Error);
1432 end Expand_N_Raise_Constraint_Error;
1434 ----------------------------------
1435 -- Expand_N_Raise_Program_Error --
1436 ----------------------------------
1438 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1440 -- We adjust the condition to deal with the C/Fortran boolean case. This
1441 -- may well not be necessary, as all such conditions are generated by
1442 -- the expander and probably are all standard boolean, but who knows
1443 -- what strange optimization in future may require this adjustment!
1445 Adjust_Condition (Condition (N));
1447 -- Now deal with possible local raise handling
1449 Possible_Local_Raise (N, Standard_Program_Error);
1450 end Expand_N_Raise_Program_Error;
1452 ------------------------------
1453 -- Expand_N_Raise_Statement --
1454 ------------------------------
1456 procedure Expand_N_Raise_Statement (N : Node_Id) is
1457 Loc : constant Source_Ptr := Sloc (N);
1465 -- Processing for locally handled exception (exclude reraise case)
1467 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1469 or else Restriction_Active (No_Exception_Propagation)
1471 -- If we have a local handler, then note that this is potentially
1472 -- able to be transformed into a goto statement.
1474 H := Find_Local_Handler (Entity (Name (N)), N);
1477 if Local_Raise_Statements (H) = No_Elist then
1478 Set_Local_Raise_Statements (H, New_Elmt_List);
1481 -- Append the new entry if it is not there already. Sometimes
1482 -- we have situations where due to reexpansion, the same node
1483 -- is analyzed twice and would otherwise be added twice.
1485 Append_Unique_Elmt (N, Local_Raise_Statements (H));
1486 Set_Has_Local_Raise (H);
1488 -- If no local handler, then generate no propagation warning
1491 Warn_If_No_Propagation (N);
1497 -- If a string expression is present, then the raise statement is
1498 -- converted to a call:
1499 -- Raise_Exception (exception-name'Identity, string);
1500 -- and there is nothing else to do.
1502 if Present (Expression (N)) then
1504 -- Avoid passing exception-name'identity in runtimes in which this
1505 -- argument is not used. This avoids generating undefined references
1506 -- to these exceptions when compiling with no optimization
1508 if Configurable_Run_Time_On_Target
1509 and then (Restriction_Active (No_Exception_Handlers)
1511 Restriction_Active (No_Exception_Propagation))
1514 Make_Procedure_Call_Statement (Loc,
1515 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1516 Parameter_Associations => New_List (
1517 New_Occurrence_Of (RTE (RE_Null_Id), Loc),
1521 Make_Procedure_Call_Statement (Loc,
1522 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1523 Parameter_Associations => New_List (
1524 Make_Attribute_Reference (Loc,
1526 Attribute_Name => Name_Identity),
1534 -- Remaining processing is for the case where no string expression is
1537 -- Don't expand a raise statement that does not come from source if we
1538 -- have already had configurable run-time violations, since most likely
1539 -- it will be junk cascaded nonsense.
1541 if Configurable_Run_Time_Violations > 0
1542 and then not Comes_From_Source (N)
1547 -- Convert explicit raise of Program_Error, Constraint_Error, and
1548 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1549 -- all other raises will get normal expansion and be disallowed,
1550 -- but this is also faster in all modes). Propagate Comes_From_Source
1551 -- flag to the new node.
1553 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1554 Src := Comes_From_Source (N);
1556 if Entity (Name (N)) = Standard_Constraint_Error then
1558 Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
1559 Set_Comes_From_Source (N, Src);
1563 elsif Entity (Name (N)) = Standard_Program_Error then
1565 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1566 Set_Comes_From_Source (N, Src);
1570 elsif Entity (Name (N)) = Standard_Storage_Error then
1572 Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
1573 Set_Comes_From_Source (N, Src);
1579 -- Case of name present, in this case we expand raise name to
1581 -- Raise_Exception (name'Identity, location_string);
1583 -- where location_string identifies the file/line of the raise
1585 if Present (Name (N)) then
1587 Id : Entity_Id := Entity (Name (N));
1591 Build_Location_String (Loc);
1593 -- If the exception is a renaming, use the exception that it
1594 -- renames (which might be a predefined exception, e.g.).
1596 if Present (Renamed_Object (Id)) then
1597 Id := Renamed_Object (Id);
1600 -- Build a C-compatible string in case of no exception handlers,
1601 -- since this is what the last chance handler is expecting.
1603 if No_Exception_Handlers_Set then
1605 -- Generate an empty message if configuration pragma
1606 -- Suppress_Exception_Locations is set for this unit.
1608 if Opt.Exception_Locations_Suppressed then
1611 Name_Len := Name_Len + 1;
1614 Name_Buffer (Name_Len) := ASCII.NUL;
1617 if Opt.Exception_Locations_Suppressed then
1621 Str := String_From_Name_Buffer;
1623 -- For VMS exceptions, convert the raise into a call to
1624 -- lib$stop so it will be handled by __gnat_error_handler.
1626 if Is_VMS_Exception (Id) then
1628 Excep_Image : String_Id;
1632 if Present (Interface_Name (Id)) then
1633 Excep_Image := Strval (Interface_Name (Id));
1635 Get_Name_String (Chars (Id));
1637 Excep_Image := String_From_Name_Buffer;
1640 if Exception_Code (Id) /= No_Uint then
1642 Make_Integer_Literal (Loc, Exception_Code (Id));
1645 Unchecked_Convert_To (Standard_Integer,
1646 Make_Function_Call (Loc,
1647 Name => New_Occurrence_Of
1648 (RTE (RE_Import_Value), Loc),
1649 Parameter_Associations => New_List
1650 (Make_String_Literal (Loc,
1651 Strval => Excep_Image))));
1655 Make_Procedure_Call_Statement (Loc,
1657 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1658 Parameter_Associations => New_List (Cond)));
1659 Analyze_And_Resolve (Cond, Standard_Integer);
1662 -- Not VMS exception case, convert raise to call to the
1663 -- Raise_Exception routine.
1667 Make_Procedure_Call_Statement (Loc,
1668 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1669 Parameter_Associations => New_List (
1670 Make_Attribute_Reference (Loc,
1672 Attribute_Name => Name_Identity),
1673 Make_String_Literal (Loc,
1678 -- Case of no name present (reraise). We rewrite the raise to:
1680 -- Reraise_Occurrence_Always (EO);
1682 -- where EO is the current exception occurrence. If the current handler
1683 -- does not have a choice parameter specification, then we provide one.
1686 -- Bypass expansion to a run-time call when back-end exception
1687 -- handling is active, unless the target is a VM, CodePeer or
1688 -- GNATprove. In CodePeer, raising an exception is treated as an
1689 -- error, while in GNATprove all code with exceptions falls outside
1690 -- the subset of code which can be formally analyzed.
1692 if VM_Target = No_VM
1693 and then not CodePeer_Mode
1694 and then Exception_Mechanism = Back_End_Exceptions
1699 -- Find innermost enclosing exception handler (there must be one,
1700 -- since the semantics has already verified that this raise statement
1701 -- is valid, and a raise with no arguments is only permitted in the
1702 -- context of an exception handler.
1704 Ehand := Parent (N);
1705 while Nkind (Ehand) /= N_Exception_Handler loop
1706 Ehand := Parent (Ehand);
1709 -- Make exception choice parameter if none present. Note that we do
1710 -- not need to put the entity on the entity chain, since no one will
1711 -- be referencing this entity by normal visibility methods.
1713 if No (Choice_Parameter (Ehand)) then
1714 E := Make_Temporary (Loc, 'E');
1715 Set_Choice_Parameter (Ehand, E);
1716 Set_Ekind (E, E_Variable);
1717 Set_Etype (E, RTE (RE_Exception_Occurrence));
1718 Set_Scope (E, Current_Scope);
1721 -- Now rewrite the raise as a call to Reraise. A special case arises
1722 -- if this raise statement occurs in the context of a handler for
1723 -- all others (i.e. an at end handler). in this case we avoid
1724 -- the call to defer abort, cleanup routines are expected to be
1725 -- called in this case with aborts deferred.
1728 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1732 if Nkind (Ech) = N_Others_Choice
1733 and then All_Others (Ech)
1735 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1737 Ent := RTE (RE_Reraise_Occurrence_Always);
1741 Make_Procedure_Call_Statement (Loc,
1742 Name => New_Occurrence_Of (Ent, Loc),
1743 Parameter_Associations => New_List (
1744 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1749 end Expand_N_Raise_Statement;
1751 ----------------------------------
1752 -- Expand_N_Raise_Storage_Error --
1753 ----------------------------------
1755 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1757 -- We adjust the condition to deal with the C/Fortran boolean case. This
1758 -- may well not be necessary, as all such conditions are generated by
1759 -- the expander and probably are all standard boolean, but who knows
1760 -- what strange optimization in future may require this adjustment!
1762 Adjust_Condition (Condition (N));
1764 -- Now deal with possible local raise handling
1766 Possible_Local_Raise (N, Standard_Storage_Error);
1767 end Expand_N_Raise_Storage_Error;
1769 --------------------------
1770 -- Possible_Local_Raise --
1771 --------------------------
1773 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1775 -- Nothing to do if local raise optimization not active
1777 if not Debug_Flag_Dot_G
1778 and then not Restriction_Active (No_Exception_Propagation)
1783 -- Nothing to do if original node was an explicit raise, because in
1784 -- that case, we already generated the required warning for the raise.
1786 if Nkind (Original_Node (N)) = N_Raise_Statement then
1790 -- Otherwise see if we have a local handler for the exception
1793 H : constant Node_Id := Find_Local_Handler (E, N);
1796 -- If so, mark that it has a local raise
1799 Set_Has_Local_Raise (H, True);
1801 -- Otherwise, if the No_Exception_Propagation restriction is active
1802 -- and the warning is enabled, generate the appropriate warnings.
1804 elsif Warn_On_Non_Local_Exception
1805 and then Restriction_Active (No_Exception_Propagation)
1807 Warn_No_Exception_Propagation_Active (N);
1809 if Configurable_Run_Time_Mode then
1811 ("\?X?& may call Last_Chance_Handler", N, E);
1814 ("\?X?& may result in unhandled exception", N, E);
1818 end Possible_Local_Raise;
1820 ------------------------------
1821 -- Expand_N_Subprogram_Info --
1822 ------------------------------
1824 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1825 Loc : constant Source_Ptr := Sloc (N);
1828 -- For now, we replace an Expand_N_Subprogram_Info node with an
1829 -- attribute reference that gives the address of the procedure.
1830 -- This is because gigi does not yet recognize this node, and
1831 -- for the initial targets, this is the right value anyway.
1834 Make_Attribute_Reference (Loc,
1835 Prefix => Identifier (N),
1836 Attribute_Name => Name_Code_Address));
1838 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1839 end Expand_N_Subprogram_Info;
1841 ------------------------
1842 -- Find_Local_Handler --
1843 ------------------------
1845 function Find_Local_Handler
1847 Nod : Node_Id) return Node_Id
1854 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1855 -- This is used to test for wrapped actions below
1858 EHandle : Entity_Id;
1859 -- The entity Id's for the exception we are raising and handling, using
1860 -- the renamed exception if a Renamed_Entity is present.
1863 -- Never any local handler if all handlers removed
1865 if Debug_Flag_Dot_X then
1869 -- Get the exception we are raising, allowing for renaming
1871 ERaise := Get_Renamed_Entity (Ename);
1873 -- We need to check if the node we are looking at is contained in
1876 -- Loop to search up the tree
1882 -- If we get to the top of the tree, or to a subprogram, task, entry,
1883 -- protected body, or accept statement without having found a
1884 -- matching handler, then there is no local handler.
1887 or else Nkind (P) = N_Subprogram_Body
1888 or else Nkind (P) = N_Task_Body
1889 or else Nkind (P) = N_Protected_Body
1890 or else Nkind (P) = N_Entry_Body
1891 or else Nkind (P) = N_Accept_Statement
1895 -- Test for handled sequence of statements with at least one
1896 -- exception handler which might be the one we are looking for.
1898 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1899 and then Present (Exception_Handlers (P))
1901 -- Before we proceed we need to check if the node N is covered
1902 -- by the statement part of P rather than one of its exception
1903 -- handlers (an exception handler obviously does not cover its
1906 -- This test is more delicate than might be thought. It is not
1907 -- just a matter of checking the Statements (P), because the node
1908 -- might be waiting to be wrapped in a transient scope, in which
1909 -- case it will end up in the block statements, even though it
1910 -- is not there now.
1912 if Is_List_Member (N) then
1914 LCN : constant List_Id := List_Containing (N);
1917 if LCN = Statements (P)
1919 LCN = SSE.Actions_To_Be_Wrapped_Before
1921 LCN = SSE.Actions_To_Be_Wrapped_After
1923 -- Loop through exception handlers
1925 H := First (Exception_Handlers (P));
1926 while Present (H) loop
1928 -- Guard against other constructs appearing in the
1929 -- list of exception handlers.
1931 if Nkind (H) = N_Exception_Handler then
1933 -- Loop through choices in one handler
1935 C := First (Exception_Choices (H));
1936 while Present (C) loop
1938 -- Deal with others case
1940 if Nkind (C) = N_Others_Choice then
1942 -- Matching others handler, but we need
1943 -- to ensure there is no choice parameter.
1944 -- If there is, then we don't have a local
1945 -- handler after all (since we do not allow
1946 -- choice parameters for local handlers).
1948 if No (Choice_Parameter (H)) then
1954 -- If not others must be entity name
1956 elsif Nkind (C) /= N_Others_Choice then
1957 pragma Assert (Is_Entity_Name (C));
1958 pragma Assert (Present (Entity (C)));
1960 -- Get exception being handled, dealing with
1963 EHandle := Get_Renamed_Entity (Entity (C));
1965 -- If match, then check choice parameter
1967 if ERaise = EHandle then
1968 if No (Choice_Parameter (H)) then
1989 end Find_Local_Handler;
1991 ---------------------------------
1992 -- Get_Local_Raise_Call_Entity --
1993 ---------------------------------
1995 -- Note: this is primary provided for use by the back end in generating
1996 -- calls to Local_Raise. But it would be too late in the back end to call
1997 -- RTE if this actually caused a load/analyze of the unit. So what we do
1998 -- is to ensure there is a dummy call to this function during front end
1999 -- processing so that the unit gets loaded then, and not later.
2001 Local_Raise_Call_Entity : Entity_Id;
2002 Local_Raise_Call_Entity_Set : Boolean := False;
2004 function Get_Local_Raise_Call_Entity return Entity_Id is
2006 if not Local_Raise_Call_Entity_Set then
2007 Local_Raise_Call_Entity_Set := True;
2009 if RTE_Available (RE_Local_Raise) then
2010 Local_Raise_Call_Entity := RTE (RE_Local_Raise);
2012 Local_Raise_Call_Entity := Empty;
2016 return Local_Raise_Call_Entity;
2017 end Get_Local_Raise_Call_Entity;
2019 -----------------------------
2020 -- Get_RT_Exception_Entity --
2021 -----------------------------
2023 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
2026 when RT_CE_Exceptions => return Standard_Constraint_Error;
2027 when RT_PE_Exceptions => return Standard_Program_Error;
2028 when RT_SE_Exceptions => return Standard_Storage_Error;
2030 end Get_RT_Exception_Entity;
2032 ---------------------------
2033 -- Get_RT_Exception_Name --
2034 ---------------------------
2036 procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is
2039 when CE_Access_Check_Failed =>
2040 Add_Str_To_Name_Buffer ("CE_Access_Check");
2041 when CE_Access_Parameter_Is_Null =>
2042 Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter");
2043 when CE_Discriminant_Check_Failed =>
2044 Add_Str_To_Name_Buffer ("CE_Discriminant_Check");
2045 when CE_Divide_By_Zero =>
2046 Add_Str_To_Name_Buffer ("CE_Divide_By_Zero");
2047 when CE_Explicit_Raise =>
2048 Add_Str_To_Name_Buffer ("CE_Explicit_Raise");
2049 when CE_Index_Check_Failed =>
2050 Add_Str_To_Name_Buffer ("CE_Index_Check");
2051 when CE_Invalid_Data =>
2052 Add_Str_To_Name_Buffer ("CE_Invalid_Data");
2053 when CE_Length_Check_Failed =>
2054 Add_Str_To_Name_Buffer ("CE_Length_Check");
2055 when CE_Null_Exception_Id =>
2056 Add_Str_To_Name_Buffer ("CE_Null_Exception_Id");
2057 when CE_Null_Not_Allowed =>
2058 Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed");
2059 when CE_Overflow_Check_Failed =>
2060 Add_Str_To_Name_Buffer ("CE_Overflow_Check");
2061 when CE_Partition_Check_Failed =>
2062 Add_Str_To_Name_Buffer ("CE_Partition_Check");
2063 when CE_Range_Check_Failed =>
2064 Add_Str_To_Name_Buffer ("CE_Range_Check");
2065 when CE_Tag_Check_Failed =>
2066 Add_Str_To_Name_Buffer ("CE_Tag_Check");
2068 when PE_Access_Before_Elaboration =>
2069 Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration");
2070 when PE_Accessibility_Check_Failed =>
2071 Add_Str_To_Name_Buffer ("PE_Accessibility_Check");
2072 when PE_Address_Of_Intrinsic =>
2073 Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic");
2074 when PE_All_Guards_Closed =>
2075 Add_Str_To_Name_Buffer ("PE_All_Guards_Closed");
2076 when PE_Bad_Predicated_Generic_Type =>
2077 Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type");
2078 when PE_Current_Task_In_Entry_Body =>
2079 Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body");
2080 when PE_Duplicated_Entry_Address =>
2081 Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address");
2082 when PE_Explicit_Raise =>
2083 Add_Str_To_Name_Buffer ("PE_Explicit_Raise");
2084 when PE_Finalize_Raised_Exception =>
2085 Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception");
2086 when PE_Implicit_Return =>
2087 Add_Str_To_Name_Buffer ("PE_Implicit_Return");
2088 when PE_Misaligned_Address_Value =>
2089 Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value");
2090 when PE_Missing_Return =>
2091 Add_Str_To_Name_Buffer ("PE_Missing_Return");
2092 when PE_Overlaid_Controlled_Object =>
2093 Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object");
2094 when PE_Potentially_Blocking_Operation =>
2095 Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation");
2096 when PE_Stubbed_Subprogram_Called =>
2097 Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called");
2098 when PE_Unchecked_Union_Restriction =>
2099 Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction");
2100 when PE_Non_Transportable_Actual =>
2101 Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual");
2103 when SE_Empty_Storage_Pool =>
2104 Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool");
2105 when SE_Explicit_Raise =>
2106 Add_Str_To_Name_Buffer ("SE_Explicit_Raise");
2107 when SE_Infinite_Recursion =>
2108 Add_Str_To_Name_Buffer ("SE_Infinite_Recursion");
2109 when SE_Object_Too_Large =>
2110 Add_Str_To_Name_Buffer ("SE_Object_Too_Large");
2112 end Get_RT_Exception_Name;
2114 ----------------------
2115 -- Is_Non_Ada_Error --
2116 ----------------------
2118 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
2120 if not OpenVMS_On_Target then
2124 Get_Name_String (Chars (E));
2126 -- Note: it is a little irregular for the body of exp_ch11 to know
2127 -- the details of the encoding scheme for names, but on the other
2128 -- hand, gigi knows them, and this is for gigi's benefit anyway!
2130 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
2135 end Is_Non_Ada_Error;
2137 ----------------------------
2138 -- Warn_If_No_Propagation --
2139 ----------------------------
2141 procedure Warn_If_No_Propagation (N : Node_Id) is
2143 if Restriction_Check_Required (No_Exception_Propagation)
2144 and then Warn_On_Non_Local_Exception
2146 Warn_No_Exception_Propagation_Active (N);
2148 if Configurable_Run_Time_Mode then
2150 ("\?X?Last_Chance_Handler will be called on exception", N);
2153 ("\?X?execution may raise unhandled exception", N);
2156 end Warn_If_No_Propagation;
2158 ------------------------------------------
2159 -- Warn_No_Exception_Propagation_Active --
2160 ------------------------------------------
2162 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
2165 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N);
2166 end Warn_No_Exception_Propagation_Active;