Merge from mainline (163495:164578).
[official-gcc/graphite-test-results.git] / gcc / ada / exp_ch11.adb
blob2efee394a1753e11fc860383f1be288ec2b97462
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 1 1 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
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;
37 with Opt; use Opt;
38 with Restrict; use Restrict;
39 with Rident; use Rident;
40 with Rtsfind; use Rtsfind;
41 with Sem; use Sem;
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:
77 -- exception
78 -- when all others =>
79 -- cleanup call
80 -- raise;
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
95 -- by the back end.
97 -- In the front end case, the exception handler described above handles
98 -- the exceptional case. The AT END handler is left in the generated tree
99 -- and the code generator (e.g. gigi) must still handle proper generation
100 -- of cleanup calls for the non-exceptional case.
102 procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
103 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
104 Loc : constant Source_Ptr := Sloc (Clean);
105 Ohandle : Node_Id;
106 Stmnts : List_Id;
108 begin
109 pragma Assert (Present (Clean));
110 pragma Assert (No (Exception_Handlers (HSS)));
112 -- Don't expand if back end exception handling active
114 if Exception_Mechanism = Back_End_Exceptions then
115 return;
116 end if;
118 -- Don't expand an At End handler if we have already had configurable
119 -- run-time violations, since likely this will just be a matter of
120 -- generating useless cascaded messages
122 if Configurable_Run_Time_Violations > 0 then
123 return;
124 end if;
126 -- Don't expand an At End handler if we are not allowing exceptions
127 -- or if exceptions are transformed into local gotos, and never
128 -- propagated (No_Exception_Propagation).
130 if No_Exception_Handlers_Set then
131 return;
132 end if;
134 if Present (Block) then
135 Push_Scope (Block);
136 end if;
138 Ohandle :=
139 Make_Others_Choice (Loc);
140 Set_All_Others (Ohandle);
142 Stmnts := New_List (
143 Make_Procedure_Call_Statement (Loc,
144 Name => New_Occurrence_Of (Clean, Loc)));
146 -- Generate reraise statement as last statement of AT-END handler,
147 -- unless we are under control of No_Exception_Propagation, in which
148 -- case no exception propagation is possible anyway, so we do not need
149 -- a reraise (the AT END handler in this case is only for normal exits
150 -- not for exceptional exits). Also, we flag the Reraise statement as
151 -- being part of an AT END handler to prevent signalling this reraise
152 -- as a violation of the restriction when it is not set.
154 if not Restriction_Active (No_Exception_Propagation) then
155 declare
156 Rstm : constant Node_Id := Make_Raise_Statement (Loc);
157 begin
158 Set_From_At_End (Rstm);
159 Append_To (Stmnts, Rstm);
160 end;
161 end if;
163 Set_Exception_Handlers (HSS, New_List (
164 Make_Implicit_Exception_Handler (Loc,
165 Exception_Choices => New_List (Ohandle),
166 Statements => Stmnts)));
168 Analyze_List (Stmnts, Suppress => All_Checks);
169 Expand_Exception_Handlers (HSS);
171 if Present (Block) then
172 Pop_Scope;
173 end if;
174 end Expand_At_End_Handler;
176 -------------------------------
177 -- Expand_Exception_Handlers --
178 -------------------------------
180 procedure Expand_Exception_Handlers (HSS : Node_Id) is
181 Handlrs : constant List_Id := Exception_Handlers (HSS);
182 Loc : constant Source_Ptr := Sloc (HSS);
183 Handler : Node_Id;
184 Others_Choice : Boolean;
185 Obj_Decl : Node_Id;
186 Next_Handler : Node_Id;
188 procedure Expand_Local_Exception_Handlers;
189 -- This procedure handles the expansion of exception handlers for the
190 -- optimization of local raise statements into goto statements.
192 procedure Prepend_Call_To_Handler
193 (Proc : RE_Id;
194 Args : List_Id := No_List);
195 -- Routine to prepend a call to the procedure referenced by Proc at
196 -- the start of the handler code for the current Handler.
198 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
199 -- Raise_S is a raise statement (possibly expanded, and possibly of the
200 -- form of a Raise_xxx_Error node with a condition. This procedure is
201 -- called to replace the raise action with the (already analyzed) goto
202 -- statement passed as Goto_L1. This procedure also takes care of the
203 -- requirement of inserting a Local_Raise call where possible.
205 -------------------------------------
206 -- Expand_Local_Exception_Handlers --
207 -------------------------------------
209 -- There are two cases for this transformation. First the case of
210 -- explicit raise statements. For this case, the transformation we do
211 -- looks like this. Right now we have for example (where L1, L2 are
212 -- exception labels)
214 -- begin
215 -- ...
216 -- raise_exception (excep1'identity); -- was raise excep1
217 -- ...
218 -- raise_exception (excep2'identity); -- was raise excep2
219 -- ...
220 -- exception
221 -- when excep1 =>
222 -- estmts1
223 -- when excep2 =>
224 -- estmts2
225 -- end;
227 -- This gets transformed into:
229 -- begin
230 -- L1 : label; -- marked Exception_Junk
231 -- L2 : label; -- marked Exception_Junk
232 -- L3 : label; -- marked Exception_Junk
234 -- begin -- marked Exception_Junk
235 -- ...
236 -- local_raise (excep1'address); -- was raise excep1
237 -- goto L1;
238 -- ...
239 -- local_raise (excep2'address); -- was raise excep2
240 -- goto L2;
241 -- ...
242 -- exception
243 -- when excep1 =>
244 -- goto L1;
245 -- when excep2 =>
246 -- goto L2;
247 -- end;
249 -- goto L3; -- skip handler if no raise, marked Exception_Junk
251 -- <<L1>> -- local excep target label, marked Exception_Junk
252 -- begin -- marked Exception_Junk
253 -- estmts1
254 -- end;
255 -- goto L3; -- marked Exception_Junk
257 -- <<L2>> -- marked Exception_Junk
258 -- begin -- marked Exception_Junk
259 -- estmts2
260 -- end;
261 -- goto L3; -- marked Exception_Junk
262 -- <<L3>> -- marked Exception_Junk
263 -- end;
265 -- Note: the reason we wrap the original statement sequence in an
266 -- inner block is that there may be raise statements within the
267 -- sequence of statements in the handlers, and we must ensure that
268 -- these are properly handled, and in particular, such raise statements
269 -- must not reenter the same exception handlers.
271 -- If the restriction No_Exception_Propagation is in effect, then we
272 -- can omit the exception handlers.
274 -- begin
275 -- L1 : label; -- marked Exception_Junk
276 -- L2 : label; -- marked Exception_Junk
277 -- L3 : label; -- marked Exception_Junk
279 -- begin -- marked Exception_Junk
280 -- ...
281 -- local_raise (excep1'address); -- was raise excep1
282 -- goto L1;
283 -- ...
284 -- local_raise (excep2'address); -- was raise excep2
285 -- goto L2;
286 -- ...
287 -- end;
289 -- goto L3; -- skip handler if no raise, marked Exception_Junk
291 -- <<L1>> -- local excep target label, marked Exception_Junk
292 -- begin -- marked Exception_Junk
293 -- estmts1
294 -- end;
295 -- goto L3; -- marked Exception_Junk
297 -- <<L2>> -- marked Exception_Junk
298 -- begin -- marked Exception_Junk
299 -- estmts2
300 -- end;
302 -- <<L3>> -- marked Exception_Junk
303 -- end;
305 -- The second case is for exceptions generated by the back end in one
306 -- of three situations:
308 -- 1. Front end generates N_Raise_xxx_Error node
309 -- 2. Front end sets Do_xxx_Check flag in subexpression node
310 -- 3. Back end detects a situation where an exception is appropriate
312 -- In all these cases, the current processing in gigi is to generate a
313 -- call to the appropriate Rcheck_xx routine (where xx encodes both the
314 -- exception message and the exception to be raised, Constraint_Error,
315 -- Program_Error, or Storage_Error.
317 -- We could handle some subcases of 1 using the same front end expansion
318 -- into gotos, but even for case 1, we can't handle all cases, since
319 -- generating gotos in the middle of expressions is not possible (it's
320 -- possible at the gigi/gcc level, but not at the level of the GNAT
321 -- tree).
323 -- In any case, it seems easier to have a scheme which handles all three
324 -- cases in a uniform manner. So here is how we proceed in this case.
326 -- This procedure detects all handlers for these three exceptions,
327 -- Constraint_Error, Program_Error and Storage_Error (including WHEN
328 -- OTHERS handlers that cover one or more of these cases).
330 -- If the handler meets the requirements for being the target of a local
331 -- raise, then the front end does the expansion described previously,
332 -- creating a label to be used as a goto target to raise the exception.
333 -- However, no attempt is made in the front end to convert any related
334 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
335 -- left unchanged and passed to the back end.
337 -- Instead, the front end generates two nodes
339 -- N_Push_Constraint_Error_Label
340 -- N_Push_Program_Error_Label
341 -- N_Push_Storage_Error_Label
343 -- The Push node is generated at the start of the statements
344 -- covered by the handler, and has as a parameter the label to be
345 -- used as the raise target.
347 -- N_Pop_Constraint_Error_Label
348 -- N_Pop_Program_Error_Label
349 -- N_Pop_Storage_Error_Label
351 -- The Pop node is generated at the end of the covered statements
352 -- and undoes the effect of the preceding corresponding Push node.
354 -- In the case where the handler does NOT meet the requirements, the
355 -- front end will still generate the Push and Pop nodes, but the label
356 -- field in the Push node will be empty signifying that for this region
357 -- of code, no optimization is possible.
359 -- The back end must maintain three stacks, one for each exception case,
360 -- the Push node pushes an entry onto the corresponding stack, and Pop
361 -- node pops off the entry. Then instead of calling Rcheck_nn, if the
362 -- corresponding top stack entry has an non-empty label, a goto is
363 -- generated. This goto should be preceded by a call to Local_Raise as
364 -- described above.
366 -- An example of this transformation is as follows, given:
368 -- declare
369 -- A : Integer range 1 .. 10;
370 -- begin
371 -- A := B + C;
372 -- exception
373 -- when Constraint_Error =>
374 -- estmts
375 -- end;
377 -- gets transformed to:
379 -- declare
380 -- A : Integer range 1 .. 10;
382 -- begin
383 -- L1 : label;
384 -- L2 : label;
386 -- begin
387 -- %push_constraint_error_label (L1)
388 -- R1b : constant long_long_integer := long_long_integer?(b) +
389 -- long_long_integer?(c);
390 -- [constraint_error when
391 -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
392 -- "overflow check failed"]
393 -- a := integer?(R1b);
394 -- %pop_constraint_error_Label
396 -- exception
397 -- ...
398 -- when constraint_error =>
399 -- goto L1;
400 -- end;
402 -- goto L2; -- skip handler when exception not raised
403 -- <<L1>> -- target label for local exception
404 -- estmts
405 -- <<L2>>
406 -- end;
408 -- Note: the generated labels and goto statements all have the flag
409 -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
410 -- this generated exception stuff when checking for missing return
411 -- statements (see circuitry in Check_Statement_Sequence).
413 -- Note: All of the processing described above occurs only if
414 -- restriction No_Exception_Propagation applies or debug flag .g is
415 -- enabled.
417 CE_Locally_Handled : Boolean := False;
418 SE_Locally_Handled : Boolean := False;
419 PE_Locally_Handled : Boolean := False;
420 -- These three flags indicate whether a handler for the corresponding
421 -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
422 -- is present. If so the switch is set to True, the Exception_Label
423 -- field of the corresponding handler is set, and appropriate Push
424 -- and Pop nodes are inserted into the code.
426 Local_Expansion_Required : Boolean := False;
427 -- Set True if we have at least one handler requiring local raise
428 -- expansion as described above.
430 procedure Expand_Local_Exception_Handlers is
432 procedure Add_Exception_Label (H : Node_Id);
433 -- H is an exception handler. First check for an Exception_Label
434 -- already allocated for H. If none, allocate one, set the field in
435 -- the handler node, add the label declaration, and set the flag
436 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
437 -- the call has no effect and Exception_Label is left empty.
439 procedure Add_Label_Declaration (L : Entity_Id);
440 -- Add an implicit declaration of the given label to the declaration
441 -- list in the parent of the current sequence of handled statements.
443 generic
444 Exc_Locally_Handled : in out Boolean;
445 -- Flag indicating whether a local handler for this exception
446 -- has already been generated.
448 with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
449 -- Function to create a Push_xxx_Label node
451 with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
452 -- Function to create a Pop_xxx_Label node
454 procedure Generate_Push_Pop (H : Node_Id);
455 -- Common code for Generate_Push_Pop_xxx below, used to generate an
456 -- exception label and Push/Pop nodes for Constraint_Error,
457 -- Program_Error, or Storage_Error.
459 -------------------------
460 -- Add_Exception_Label --
461 -------------------------
463 procedure Add_Exception_Label (H : Node_Id) is
464 begin
465 if No (Exception_Label (H))
466 and then not Local_Raise_Not_OK (H)
467 and then not Special_Exception_Package_Used
468 then
469 Local_Expansion_Required := True;
471 declare
472 L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
473 begin
474 Set_Exception_Label (H, L);
475 Add_Label_Declaration (L);
476 end;
477 end if;
478 end Add_Exception_Label;
480 ---------------------------
481 -- Add_Label_Declaration --
482 ---------------------------
484 procedure Add_Label_Declaration (L : Entity_Id) is
485 P : constant Node_Id := Parent (HSS);
487 Decl_L : constant Node_Id :=
488 Make_Implicit_Label_Declaration (Loc,
489 Defining_Identifier => L);
491 begin
492 if Declarations (P) = No_List then
493 Set_Declarations (P, Empty_List);
494 end if;
496 Append (Decl_L, Declarations (P));
497 Analyze (Decl_L);
498 end Add_Label_Declaration;
500 -----------------------
501 -- Generate_Push_Pop --
502 -----------------------
504 procedure Generate_Push_Pop (H : Node_Id) is
505 begin
506 if Exc_Locally_Handled then
507 return;
508 else
509 Exc_Locally_Handled := True;
510 end if;
512 Add_Exception_Label (H);
514 declare
515 F : constant Node_Id := First (Statements (HSS));
516 L : constant Node_Id := Last (Statements (HSS));
518 Push : constant Node_Id := Make_Push_Label (Sloc (F));
519 Pop : constant Node_Id := Make_Pop_Label (Sloc (L));
521 begin
522 -- We make sure that a call to Get_Local_Raise_Call_Entity is
523 -- made during front end processing, so that when we need it
524 -- in the back end, it will already be available and loaded.
526 Discard_Node (Get_Local_Raise_Call_Entity);
528 -- Prepare and insert Push and Pop nodes
530 Set_Exception_Label (Push, Exception_Label (H));
531 Insert_Before (F, Push);
532 Set_Analyzed (Push);
534 Insert_After (L, Pop);
535 Set_Analyzed (Pop);
536 end;
537 end Generate_Push_Pop;
539 -- Local declarations
541 Loc : constant Source_Ptr := Sloc (HSS);
542 Stmts : List_Id := No_List;
543 Choice : Node_Id;
544 Excep : Entity_Id;
546 procedure Generate_Push_Pop_For_Constraint_Error is
547 new Generate_Push_Pop
548 (Exc_Locally_Handled => CE_Locally_Handled,
549 Make_Push_Label => Make_Push_Constraint_Error_Label,
550 Make_Pop_Label => Make_Pop_Constraint_Error_Label);
551 -- If no Push/Pop has been generated for CE yet, then set the flag
552 -- CE_Locally_Handled, allocate an Exception_Label for handler H (if
553 -- not already done), and generate Push/Pop nodes for the exception
554 -- label at the start and end of the statements of HSS.
556 procedure Generate_Push_Pop_For_Program_Error is
557 new Generate_Push_Pop
558 (Exc_Locally_Handled => PE_Locally_Handled,
559 Make_Push_Label => Make_Push_Program_Error_Label,
560 Make_Pop_Label => Make_Pop_Program_Error_Label);
561 -- If no Push/Pop has been generated for PE yet, then set the flag
562 -- PE_Locally_Handled, allocate an Exception_Label for handler H (if
563 -- not already done), and generate Push/Pop nodes for the exception
564 -- label at the start and end of the statements of HSS.
566 procedure Generate_Push_Pop_For_Storage_Error is
567 new Generate_Push_Pop
568 (Exc_Locally_Handled => SE_Locally_Handled,
569 Make_Push_Label => Make_Push_Storage_Error_Label,
570 Make_Pop_Label => Make_Pop_Storage_Error_Label);
571 -- If no Push/Pop has been generated for SE yet, then set the flag
572 -- SE_Locally_Handled, allocate an Exception_Label for handler H (if
573 -- not already done), and generate Push/Pop nodes for the exception
574 -- label at the start and end of the statements of HSS.
576 -- Start of processing for Expand_Local_Exception_Handlers
578 begin
579 -- No processing if all exception handlers will get removed
581 if Debug_Flag_Dot_X then
582 return;
583 end if;
585 -- See for each handler if we have any local raises to expand
587 Handler := First_Non_Pragma (Handlrs);
588 while Present (Handler) loop
590 -- Note, we do not test Local_Raise_Not_OK here, because in the
591 -- case of Push/Pop generation we want to generate push with a
592 -- null label. The Add_Exception_Label routine has no effect if
593 -- Local_Raise_Not_OK is set, so this works as required.
595 if Present (Local_Raise_Statements (Handler)) then
596 Add_Exception_Label (Handler);
597 end if;
599 -- If we are doing local raise to goto optimization (restriction
600 -- No_Exception_Propagation set or debug flag .g set), then check
601 -- to see if handler handles CE, PE, SE and if so generate the
602 -- appropriate push/pop sequence for the back end.
604 if (Debug_Flag_Dot_G
605 or else Restriction_Active (No_Exception_Propagation))
606 and then Has_Local_Raise (Handler)
607 then
608 Choice := First (Exception_Choices (Handler));
609 while Present (Choice) loop
610 if Nkind (Choice) = N_Others_Choice
611 and then not All_Others (Choice)
612 then
613 Generate_Push_Pop_For_Constraint_Error (Handler);
614 Generate_Push_Pop_For_Program_Error (Handler);
615 Generate_Push_Pop_For_Storage_Error (Handler);
617 elsif Is_Entity_Name (Choice) then
618 Excep := Get_Renamed_Entity (Entity (Choice));
620 if Excep = Standard_Constraint_Error then
621 Generate_Push_Pop_For_Constraint_Error (Handler);
622 elsif Excep = Standard_Program_Error then
623 Generate_Push_Pop_For_Program_Error (Handler);
624 elsif Excep = Standard_Storage_Error then
625 Generate_Push_Pop_For_Storage_Error (Handler);
626 end if;
627 end if;
629 Next (Choice);
630 end loop;
631 end if;
633 Next_Non_Pragma (Handler);
634 end loop;
636 -- Nothing to do if no handlers requiring the goto transformation
638 if not (Local_Expansion_Required) then
639 return;
640 end if;
642 -- Prepare to do the transformation
644 declare
645 -- L3 is the label to exit the HSS
647 L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
649 Labl_L3 : constant Node_Id :=
650 Make_Label (Loc,
651 Identifier => New_Occurrence_Of (L3_Dent, Loc));
653 Blk_Stm : Node_Id;
654 Relmt : Elmt_Id;
656 begin
657 Set_Exception_Junk (Labl_L3);
658 Add_Label_Declaration (L3_Dent);
660 -- Wrap existing statements and handlers in an inner block
662 Blk_Stm :=
663 Make_Block_Statement (Loc,
664 Handled_Statement_Sequence => Relocate_Node (HSS));
665 Set_Exception_Junk (Blk_Stm);
667 Rewrite (HSS,
668 Make_Handled_Sequence_Of_Statements (Loc,
669 Statements => New_List (Blk_Stm),
670 End_Label => Relocate_Node (End_Label (HSS))));
672 -- Set block statement as analyzed, we don't want to actually call
673 -- Analyze on this block, it would cause a recursion in exception
674 -- handler processing which would mess things up.
676 Set_Analyzed (Blk_Stm);
678 -- Now loop through the exception handlers to deal with those that
679 -- are targets of local raise statements.
681 Handler := First_Non_Pragma (Handlrs);
682 while Present (Handler) loop
683 if Present (Exception_Label (Handler)) then
685 -- This handler needs the goto expansion
687 declare
688 Loc : constant Source_Ptr := Sloc (Handler);
690 -- L1 is the start label for this handler
692 L1_Dent : constant Entity_Id := Exception_Label (Handler);
694 Labl_L1 : constant Node_Id :=
695 Make_Label (Loc,
696 Identifier =>
697 New_Occurrence_Of (L1_Dent, Loc));
699 -- Jump to L1 to be used as replacement for the original
700 -- handler (used in the case where exception propagation
701 -- may still occur).
703 Name_L1 : constant Node_Id :=
704 New_Occurrence_Of (L1_Dent, Loc);
706 Goto_L1 : constant Node_Id :=
707 Make_Goto_Statement (Loc,
708 Name => Name_L1);
710 -- Jump to L3 to be used at the end of handler
712 Name_L3 : constant Node_Id :=
713 New_Occurrence_Of (L3_Dent, Loc);
715 Goto_L3 : constant Node_Id :=
716 Make_Goto_Statement (Loc,
717 Name => Name_L3);
719 H_Stmts : constant List_Id := Statements (Handler);
721 begin
722 Set_Exception_Junk (Labl_L1);
723 Set_Exception_Junk (Goto_L3);
725 -- Note: we do NOT set Exception_Junk in Goto_L1, since
726 -- this is a real transfer of control that we want the
727 -- Sem_Ch6.Check_Returns procedure to recognize properly.
729 -- Replace handler by a goto L1. We can mark this as
730 -- analyzed since it is fully formed, and we don't
731 -- want it going through any further checks. We save
732 -- the last statement location in the goto L1 node for
733 -- the benefit of Sem_Ch6.Check_Returns.
735 Set_Statements (Handler, New_List (Goto_L1));
736 Set_Analyzed (Goto_L1);
737 Set_Etype (Name_L1, Standard_Void_Type);
739 -- Now replace all the raise statements by goto L1
741 if Present (Local_Raise_Statements (Handler)) then
742 Relmt := First_Elmt (Local_Raise_Statements (Handler));
743 while Present (Relmt) loop
744 declare
745 Raise_S : constant Node_Id := Node (Relmt);
746 RLoc : constant Source_Ptr := Sloc (Raise_S);
747 Name_L1 : constant Node_Id :=
748 New_Occurrence_Of (L1_Dent, Loc);
749 Goto_L1 : constant Node_Id :=
750 Make_Goto_Statement (RLoc,
751 Name => Name_L1);
753 begin
754 -- Replace raise by goto L1
756 Set_Analyzed (Goto_L1);
757 Set_Etype (Name_L1, Standard_Void_Type);
758 Replace_Raise_By_Goto (Raise_S, Goto_L1);
759 end;
761 Next_Elmt (Relmt);
762 end loop;
763 end if;
765 -- Add a goto L3 at end of statement list in block. The
766 -- first time, this is what skips over the exception
767 -- handlers in the normal case. Subsequent times, it
768 -- terminates the execution of the previous handler code,
769 -- and skips subsequent handlers.
771 Stmts := Statements (HSS);
773 Insert_After (Last (Stmts), Goto_L3);
774 Set_Analyzed (Goto_L3);
775 Set_Etype (Name_L3, Standard_Void_Type);
777 -- Now we drop the label that marks the handler start,
778 -- followed by the statements of the handler.
780 Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
782 Insert_After_And_Analyze (Last (Stmts), Labl_L1);
784 declare
785 Loc : constant Source_Ptr := Sloc (First (H_Stmts));
786 Blk : constant Node_Id :=
787 Make_Block_Statement (Loc,
788 Handled_Statement_Sequence =>
789 Make_Handled_Sequence_Of_Statements (Loc,
790 Statements => H_Stmts));
791 begin
792 Set_Exception_Junk (Blk);
793 Insert_After_And_Analyze (Last (Stmts), Blk);
794 end;
795 end;
797 -- Here if we have local raise statements but the handler is
798 -- not suitable for processing with a local raise. In this
799 -- case we have to generate possible diagnostics.
801 elsif Has_Local_Raise (Handler)
802 and then Local_Raise_Statements (Handler) /= No_Elist
803 then
804 Relmt := First_Elmt (Local_Raise_Statements (Handler));
805 while Present (Relmt) loop
806 Warn_If_No_Propagation (Node (Relmt));
807 Next_Elmt (Relmt);
808 end loop;
809 end if;
811 Next (Handler);
812 end loop;
814 -- Only remaining step is to drop the L3 label and we are done
816 Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
818 -- If we had at least one handler, then we drop the label after
819 -- the last statement of that handler.
821 if Stmts /= No_List then
822 Insert_After_And_Analyze (Last (Stmts), Labl_L3);
824 -- Otherwise we have removed all the handlers (this results from
825 -- use of pragma Restrictions (No_Exception_Propagation), and we
826 -- drop the label at the end of the statements of the HSS.
828 else
829 Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
830 end if;
832 return;
833 end;
834 end Expand_Local_Exception_Handlers;
836 -----------------------------
837 -- Prepend_Call_To_Handler --
838 -----------------------------
840 procedure Prepend_Call_To_Handler
841 (Proc : RE_Id;
842 Args : List_Id := No_List)
844 Ent : constant Entity_Id := RTE (Proc);
846 begin
847 -- If we have no Entity, then we are probably in no run time mode or
848 -- some weird error has occurred. In either case do nothing. Note use
849 -- of No_Location to hide this code from the debugger, so single
850 -- stepping doesn't jump back and forth.
852 if Present (Ent) then
853 declare
854 Call : constant Node_Id :=
855 Make_Procedure_Call_Statement (No_Location,
856 Name => New_Occurrence_Of (RTE (Proc), No_Location),
857 Parameter_Associations => Args);
859 begin
860 Prepend_To (Statements (Handler), Call);
861 Analyze (Call, Suppress => All_Checks);
862 end;
863 end if;
864 end Prepend_Call_To_Handler;
866 ---------------------------
867 -- Replace_Raise_By_Goto --
868 ---------------------------
870 procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
871 Loc : constant Source_Ptr := Sloc (Raise_S);
872 Excep : Entity_Id;
873 LR : Node_Id;
874 Cond : Node_Id;
875 Orig : Node_Id;
877 begin
878 -- If we have a null statement, it means that there is no replacement
879 -- needed (typically this results from a suppressed check).
881 if Nkind (Raise_S) = N_Null_Statement then
882 return;
884 -- Test for Raise_xxx_Error
886 elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
887 Excep := Standard_Constraint_Error;
888 Cond := Condition (Raise_S);
890 elsif Nkind (Raise_S) = N_Raise_Storage_Error then
891 Excep := Standard_Storage_Error;
892 Cond := Condition (Raise_S);
894 elsif Nkind (Raise_S) = N_Raise_Program_Error then
895 Excep := Standard_Program_Error;
896 Cond := Condition (Raise_S);
898 -- The only other possibility is a node that is or used to be a
899 -- simple raise statement.
901 else
902 Orig := Original_Node (Raise_S);
903 pragma Assert (Nkind (Orig) = N_Raise_Statement
904 and then Present (Name (Orig))
905 and then No (Expression (Orig)));
906 Excep := Entity (Name (Orig));
907 Cond := Empty;
908 end if;
910 -- Here Excep is the exception to raise, and Cond is the condition
911 -- First prepare the call to Local_Raise (excep'address).
913 if RTE_Available (RE_Local_Raise) then
914 LR :=
915 Make_Procedure_Call_Statement (Loc,
916 Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
917 Parameter_Associations => New_List (
918 Unchecked_Convert_To (RTE (RE_Address),
919 Make_Attribute_Reference (Loc,
920 Prefix => New_Occurrence_Of (Excep, Loc),
921 Attribute_Name => Name_Identity))));
923 -- Use null statement if Local_Raise not available
925 else
926 LR :=
927 Make_Null_Statement (Loc);
928 end if;
930 -- If there is no condition, we rewrite as
932 -- begin
933 -- Local_Raise (excep'Identity);
934 -- goto L1;
935 -- end;
937 if No (Cond) then
938 Rewrite (Raise_S,
939 Make_Block_Statement (Loc,
940 Handled_Statement_Sequence =>
941 Make_Handled_Sequence_Of_Statements (Loc,
942 Statements => New_List (LR, Goto_L1))));
943 Set_Exception_Junk (Raise_S);
945 -- If there is a condition, we rewrite as
947 -- if condition then
948 -- Local_Raise (excep'Identity);
949 -- goto L1;
950 -- end if;
952 else
953 Rewrite (Raise_S,
954 Make_If_Statement (Loc,
955 Condition => Cond,
956 Then_Statements => New_List (LR, Goto_L1)));
957 end if;
959 Analyze (Raise_S);
960 end Replace_Raise_By_Goto;
962 -- Start of processing for Expand_Exception_Handlers
964 begin
965 Expand_Local_Exception_Handlers;
967 -- Loop through handlers
969 Handler := First_Non_Pragma (Handlrs);
970 Handler_Loop : while Present (Handler) loop
971 Next_Handler := Next_Non_Pragma (Handler);
973 -- Remove source handler if gnat debug flag .x is set
975 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
976 Remove (Handler);
978 -- Remove handler if no exception propagation, generating a warning
979 -- if a source generated handler was not the target of a local raise.
981 else
982 if Restriction_Active (No_Exception_Propagation)
983 and then not Has_Local_Raise (Handler)
984 and then Comes_From_Source (Handler)
985 and then Warn_On_Non_Local_Exception
986 then
987 Warn_No_Exception_Propagation_Active (Handler);
988 Error_Msg_N
989 ("\?this handler can never be entered, and has been removed",
990 Handler);
991 end if;
993 if No_Exception_Propagation_Active then
994 Remove (Handler);
996 -- Exception handler is active and retained and must be processed
998 else
999 -- If an exception occurrence is present, then we must declare
1000 -- it and initialize it from the value stored in the TSD
1002 -- declare
1003 -- name : Exception_Occurrence;
1004 -- begin
1005 -- Save_Occurrence (name, Get_Current_Excep.all)
1006 -- ...
1007 -- end;
1009 if Present (Choice_Parameter (Handler)) then
1010 declare
1011 Cparm : constant Entity_Id := Choice_Parameter (Handler);
1012 Cloc : constant Source_Ptr := Sloc (Cparm);
1013 Hloc : constant Source_Ptr := Sloc (Handler);
1014 Save : Node_Id;
1016 begin
1017 -- Note use of No_Location to hide this code from the
1018 -- debugger, so single stepping doesn't jump back and
1019 -- forth.
1021 Save :=
1022 Make_Procedure_Call_Statement (No_Location,
1023 Name =>
1024 New_Occurrence_Of (RTE (RE_Save_Occurrence),
1025 No_Location),
1026 Parameter_Associations => New_List (
1027 New_Occurrence_Of (Cparm, Cloc),
1028 Make_Explicit_Dereference (No_Location,
1029 Make_Function_Call (No_Location,
1030 Name => Make_Explicit_Dereference (No_Location,
1031 New_Occurrence_Of
1032 (RTE (RE_Get_Current_Excep),
1033 No_Location))))));
1035 Mark_Rewrite_Insertion (Save);
1036 Prepend (Save, Statements (Handler));
1038 Obj_Decl :=
1039 Make_Object_Declaration
1040 (Cloc,
1041 Defining_Identifier => Cparm,
1042 Object_Definition =>
1043 New_Occurrence_Of
1044 (RTE (RE_Exception_Occurrence), Cloc));
1045 Set_No_Initialization (Obj_Decl, True);
1047 Rewrite (Handler,
1048 Make_Exception_Handler (Hloc,
1049 Choice_Parameter => Empty,
1050 Exception_Choices => Exception_Choices (Handler),
1052 Statements => New_List (
1053 Make_Block_Statement (Hloc,
1054 Declarations => New_List (Obj_Decl),
1055 Handled_Statement_Sequence =>
1056 Make_Handled_Sequence_Of_Statements (Hloc,
1057 Statements => Statements (Handler))))));
1059 -- Local raise statements can't occur, since exception
1060 -- handlers with choice parameters are not allowed when
1061 -- No_Exception_Propagation applies, so set attributes
1062 -- accordingly.
1064 Set_Local_Raise_Statements (Handler, No_Elist);
1065 Set_Local_Raise_Not_OK (Handler);
1067 Analyze_List
1068 (Statements (Handler), Suppress => All_Checks);
1069 end;
1070 end if;
1072 -- The processing at this point is rather different for the JVM
1073 -- case, so we completely separate the processing.
1075 -- For the VM case, we unconditionally call Update_Exception,
1076 -- passing a call to the intrinsic Current_Target_Exception
1077 -- (see JVM/.NET versions of Ada.Exceptions for details).
1079 if VM_Target /= No_VM then
1080 declare
1081 Arg : constant Node_Id :=
1082 Make_Function_Call (Loc,
1083 Name =>
1084 New_Occurrence_Of
1085 (RTE (RE_Current_Target_Exception), Loc));
1086 begin
1087 Prepend_Call_To_Handler
1088 (RE_Update_Exception, New_List (Arg));
1089 end;
1091 -- For the normal case, we have to worry about the state of
1092 -- abort deferral. Generally, we defer abort during runtime
1093 -- handling of exceptions. When control is passed to the
1094 -- handler, then in the normal case we undefer aborts. In
1095 -- any case this entire handling is relevant only if aborts
1096 -- are allowed!
1098 elsif Abort_Allowed then
1100 -- There are some special cases in which we do not do the
1101 -- undefer. In particular a finalization (AT END) handler
1102 -- wants to operate with aborts still deferred.
1104 -- We also suppress the call if this is the special handler
1105 -- for Abort_Signal, since if we are aborting, we want to
1106 -- keep aborts deferred (one abort is enough).
1108 -- If abort really needs to be deferred the expander must
1109 -- add this call explicitly, see
1110 -- Expand_N_Asynchronous_Select.
1112 Others_Choice :=
1113 Nkind (First (Exception_Choices (Handler))) =
1114 N_Others_Choice;
1116 if (Others_Choice
1117 or else Entity (First (Exception_Choices (Handler))) /=
1118 Stand.Abort_Signal)
1119 and then not
1120 (Others_Choice
1121 and then
1122 All_Others (First (Exception_Choices (Handler))))
1123 and then Abort_Allowed
1124 then
1125 Prepend_Call_To_Handler (RE_Abort_Undefer);
1126 end if;
1127 end if;
1128 end if;
1129 end if;
1131 Handler := Next_Handler;
1132 end loop Handler_Loop;
1134 -- If all handlers got removed, then remove the list. Note we cannot
1135 -- reference HSS here, since expanding local handlers may have buried
1136 -- the handlers in an inner block.
1138 if Is_Empty_List (Handlrs) then
1139 Set_Exception_Handlers (Parent (Handlrs), No_List);
1140 end if;
1141 end Expand_Exception_Handlers;
1143 ------------------------------------
1144 -- Expand_N_Exception_Declaration --
1145 ------------------------------------
1147 -- Generates:
1148 -- exceptE : constant String := "A.B.EXCEP"; -- static data
1149 -- except : exception_data := (
1150 -- Handled_By_Other => False,
1151 -- Lang => 'A',
1152 -- Name_Length => exceptE'Length,
1153 -- Full_Name => exceptE'Address,
1154 -- HTable_Ptr => null,
1155 -- Import_Code => 0,
1156 -- Raise_Hook => null,
1157 -- );
1159 -- (protecting test only needed if not at library level)
1161 -- exceptF : Boolean := True -- static data
1162 -- if exceptF then
1163 -- exceptF := False;
1164 -- Register_Exception (except'Unchecked_Access);
1165 -- end if;
1167 procedure Expand_N_Exception_Declaration (N : Node_Id) is
1168 Loc : constant Source_Ptr := Sloc (N);
1169 Id : constant Entity_Id := Defining_Identifier (N);
1170 L : List_Id := New_List;
1171 Flag_Id : Entity_Id;
1173 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1174 Exname : constant Node_Id :=
1175 Make_Defining_Identifier (Loc, Name_Exname);
1177 procedure Force_Static_Allocation_Of_Referenced_Objects
1178 (Aggregate : Node_Id);
1179 -- A specialized solution to one particular case of an ugly problem
1181 -- The given aggregate includes an Unchecked_Conversion as one of the
1182 -- component values. The call to Analyze_And_Resolve below ends up
1183 -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1184 -- to introduce a (constant) temporary and then obtain the component
1185 -- value by evaluating the temporary.
1187 -- In the case of an exception declared within a subprogram (or any
1188 -- other dynamic scope), this is a bad transformation. The exception
1189 -- object is marked as being Statically_Allocated but the temporary is
1190 -- not. If the initial value of a Statically_Allocated declaration
1191 -- references a dynamically allocated object, this prevents static
1192 -- initialization of the object.
1194 -- We cope with this here by marking the temporary Statically_Allocated.
1195 -- It might seem cleaner to generalize this utility and then use it to
1196 -- enforce a rule that the entities referenced in the declaration of any
1197 -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1198 -- entity must also be either Library_Level or hoisted. It turns out
1199 -- that this would be incompatible with the current treatment of an
1200 -- object which is local to a subprogram, subject to an Export pragma,
1201 -- not subject to an address clause, and whose declaration contains
1202 -- references to other local (non-hoisted) objects (e.g., in the initial
1203 -- value expression).
1205 ---------------------------------------------------
1206 -- Force_Static_Allocation_Of_Referenced_Objects --
1207 ---------------------------------------------------
1209 procedure Force_Static_Allocation_Of_Referenced_Objects
1210 (Aggregate : Node_Id)
1212 function Fixup_Node (N : Node_Id) return Traverse_Result;
1213 -- If the given node references a dynamically allocated object, then
1214 -- correct the declaration of the object.
1216 ----------------
1217 -- Fixup_Node --
1218 ----------------
1220 function Fixup_Node (N : Node_Id) return Traverse_Result is
1221 begin
1222 if Nkind (N) in N_Has_Entity
1223 and then Present (Entity (N))
1224 and then not Is_Library_Level_Entity (Entity (N))
1226 -- Note: the following test is not needed but it seems cleaner
1227 -- to do this test (this would be more important if procedure
1228 -- Force_Static_Allocation_Of_Referenced_Objects recursively
1229 -- traversed the declaration of an entity after marking it as
1230 -- statically allocated).
1232 and then not Is_Statically_Allocated (Entity (N))
1233 then
1234 Set_Is_Statically_Allocated (Entity (N));
1235 end if;
1237 return OK;
1238 end Fixup_Node;
1240 procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
1242 -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1244 begin
1245 Fixup_Tree (Aggregate);
1246 end Force_Static_Allocation_Of_Referenced_Objects;
1248 -- Start of processing for Expand_N_Exception_Declaration
1250 begin
1251 -- There is no expansion needed when compiling for the JVM since the
1252 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
1254 if VM_Target /= No_VM then
1255 return;
1256 end if;
1258 -- Definition of the external name: nam : constant String := "A.B.NAME";
1260 Insert_Action (N,
1261 Make_Object_Declaration (Loc,
1262 Defining_Identifier => Exname,
1263 Constant_Present => True,
1264 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1265 Expression =>
1266 Make_String_Literal (Loc,
1267 Strval => Full_Qualified_Name (Id))));
1269 Set_Is_Statically_Allocated (Exname);
1271 -- Create the aggregate list for type Standard.Exception_Type:
1272 -- Handled_By_Other component: False
1274 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1276 -- Lang component: 'A'
1278 Append_To (L,
1279 Make_Character_Literal (Loc,
1280 Chars => Name_uA,
1281 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
1283 -- Name_Length component: Nam'Length
1285 Append_To (L,
1286 Make_Attribute_Reference (Loc,
1287 Prefix => New_Occurrence_Of (Exname, Loc),
1288 Attribute_Name => Name_Length));
1290 -- Full_Name component: Standard.A_Char!(Nam'Address)
1292 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1293 Make_Attribute_Reference (Loc,
1294 Prefix => New_Occurrence_Of (Exname, Loc),
1295 Attribute_Name => Name_Address)));
1297 -- HTable_Ptr component: null
1299 Append_To (L, Make_Null (Loc));
1301 -- Import_Code component: 0
1303 Append_To (L, Make_Integer_Literal (Loc, 0));
1305 -- Raise_Hook component: null
1307 Append_To (L, Make_Null (Loc));
1309 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1310 Analyze_And_Resolve (Expression (N), Etype (Id));
1312 Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
1314 -- Register_Exception (except'Unchecked_Access);
1316 if not No_Exception_Handlers_Set
1317 and then not Restriction_Active (No_Exception_Registration)
1318 then
1319 L := New_List (
1320 Make_Procedure_Call_Statement (Loc,
1321 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1322 Parameter_Associations => New_List (
1323 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1324 Make_Attribute_Reference (Loc,
1325 Prefix => New_Occurrence_Of (Id, Loc),
1326 Attribute_Name => Name_Unrestricted_Access)))));
1328 Set_Register_Exception_Call (Id, First (L));
1330 if not Is_Library_Level_Entity (Id) then
1331 Flag_Id := Make_Defining_Identifier (Loc,
1332 New_External_Name (Chars (Id), 'F'));
1334 Insert_Action (N,
1335 Make_Object_Declaration (Loc,
1336 Defining_Identifier => Flag_Id,
1337 Object_Definition =>
1338 New_Occurrence_Of (Standard_Boolean, Loc),
1339 Expression =>
1340 New_Occurrence_Of (Standard_True, Loc)));
1342 Set_Is_Statically_Allocated (Flag_Id);
1344 Append_To (L,
1345 Make_Assignment_Statement (Loc,
1346 Name => New_Occurrence_Of (Flag_Id, Loc),
1347 Expression => New_Occurrence_Of (Standard_False, Loc)));
1349 Insert_After_And_Analyze (N,
1350 Make_Implicit_If_Statement (N,
1351 Condition => New_Occurrence_Of (Flag_Id, Loc),
1352 Then_Statements => L));
1354 else
1355 Insert_List_After_And_Analyze (N, L);
1356 end if;
1357 end if;
1358 end Expand_N_Exception_Declaration;
1360 ---------------------------------------------
1361 -- Expand_N_Handled_Sequence_Of_Statements --
1362 ---------------------------------------------
1364 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1365 begin
1366 -- Expand exception handlers
1368 if Present (Exception_Handlers (N))
1369 and then not Restriction_Active (No_Exception_Handlers)
1370 then
1371 Expand_Exception_Handlers (N);
1372 end if;
1374 -- If local exceptions are being expanded, the previous call will
1375 -- have rewritten the construct as a block and reanalyzed it. No
1376 -- further expansion is needed.
1378 if Analyzed (N) then
1379 return;
1380 end if;
1382 -- Add clean up actions if required
1384 if Nkind (Parent (N)) /= N_Package_Body
1385 and then Nkind (Parent (N)) /= N_Accept_Statement
1386 and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1387 and then not Delay_Cleanups (Current_Scope)
1388 then
1389 Expand_Cleanup_Actions (Parent (N));
1390 else
1391 Set_First_Real_Statement (N, First (Statements (N)));
1392 end if;
1393 end Expand_N_Handled_Sequence_Of_Statements;
1395 -------------------------------------
1396 -- Expand_N_Raise_Constraint_Error --
1397 -------------------------------------
1399 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1400 begin
1401 -- We adjust the condition to deal with the C/Fortran boolean case. This
1402 -- may well not be necessary, as all such conditions are generated by
1403 -- the expander and probably are all standard boolean, but who knows
1404 -- what strange optimization in future may require this adjustment!
1406 Adjust_Condition (Condition (N));
1408 -- Now deal with possible local raise handling
1410 Possible_Local_Raise (N, Standard_Constraint_Error);
1411 end Expand_N_Raise_Constraint_Error;
1413 ----------------------------------
1414 -- Expand_N_Raise_Program_Error --
1415 ----------------------------------
1417 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1418 begin
1419 -- We adjust the condition to deal with the C/Fortran boolean case. This
1420 -- may well not be necessary, as all such conditions are generated by
1421 -- the expander and probably are all standard boolean, but who knows
1422 -- what strange optimization in future may require this adjustment!
1424 Adjust_Condition (Condition (N));
1426 -- Now deal with possible local raise handling
1428 Possible_Local_Raise (N, Standard_Program_Error);
1429 end Expand_N_Raise_Program_Error;
1431 ------------------------------
1432 -- Expand_N_Raise_Statement --
1433 ------------------------------
1435 procedure Expand_N_Raise_Statement (N : Node_Id) is
1436 Loc : constant Source_Ptr := Sloc (N);
1437 Ehand : Node_Id;
1438 E : Entity_Id;
1439 Str : String_Id;
1440 H : Node_Id;
1442 begin
1443 -- Processing for locally handled exception (exclude reraise case)
1445 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1446 if Debug_Flag_Dot_G
1447 or else Restriction_Active (No_Exception_Propagation)
1448 then
1449 -- If we have a local handler, then note that this is potentially
1450 -- able to be transformed into a goto statement.
1452 H := Find_Local_Handler (Entity (Name (N)), N);
1454 if Present (H) then
1455 if Local_Raise_Statements (H) = No_Elist then
1456 Set_Local_Raise_Statements (H, New_Elmt_List);
1457 end if;
1459 -- Append the new entry if it is not there already. Sometimes
1460 -- we have situations where due to reexpansion, the same node
1461 -- is analyzed twice and would otherwise be added twice.
1463 Append_Unique_Elmt (N, Local_Raise_Statements (H));
1464 Set_Has_Local_Raise (H);
1466 -- If no local handler, then generate no propagation warning
1468 else
1469 Warn_If_No_Propagation (N);
1470 end if;
1472 end if;
1473 end if;
1475 -- If a string expression is present, then the raise statement is
1476 -- converted to a call:
1477 -- Raise_Exception (exception-name'Identity, string);
1478 -- and there is nothing else to do.
1480 if Present (Expression (N)) then
1482 -- Avoid passing exception-name'identity in runtimes in which this
1483 -- argument is not used. This avoids generating undefined references
1484 -- to these exceptions when compiling with no optimization
1486 if Configurable_Run_Time_On_Target
1487 and then (Restriction_Active (No_Exception_Handlers)
1488 or else
1489 Restriction_Active (No_Exception_Propagation))
1490 then
1491 Rewrite (N,
1492 Make_Procedure_Call_Statement (Loc,
1493 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1494 Parameter_Associations => New_List (
1495 New_Occurrence_Of (RTE (RE_Null_Id), Loc),
1496 Expression (N))));
1497 else
1498 Rewrite (N,
1499 Make_Procedure_Call_Statement (Loc,
1500 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1501 Parameter_Associations => New_List (
1502 Make_Attribute_Reference (Loc,
1503 Prefix => Name (N),
1504 Attribute_Name => Name_Identity),
1505 Expression (N))));
1506 end if;
1508 Analyze (N);
1509 return;
1510 end if;
1512 -- Remaining processing is for the case where no string expression
1513 -- is present.
1515 -- Don't expand a raise statement that does not come from source
1516 -- if we have already had configurable run-time violations, since
1517 -- most likely it will be junk cascaded nonsense.
1519 if Configurable_Run_Time_Violations > 0
1520 and then not Comes_From_Source (N)
1521 then
1522 return;
1523 end if;
1525 -- Convert explicit raise of Program_Error, Constraint_Error, and
1526 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1527 -- all other raises will get normal expansion and be disallowed,
1528 -- but this is also faster in all modes).
1530 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1531 if Entity (Name (N)) = Standard_Constraint_Error then
1532 Rewrite (N,
1533 Make_Raise_Constraint_Error (Loc,
1534 Reason => CE_Explicit_Raise));
1535 Analyze (N);
1536 return;
1538 elsif Entity (Name (N)) = Standard_Program_Error then
1539 Rewrite (N,
1540 Make_Raise_Program_Error (Loc,
1541 Reason => PE_Explicit_Raise));
1542 Analyze (N);
1543 return;
1545 elsif Entity (Name (N)) = Standard_Storage_Error then
1546 Rewrite (N,
1547 Make_Raise_Storage_Error (Loc,
1548 Reason => SE_Explicit_Raise));
1549 Analyze (N);
1550 return;
1551 end if;
1552 end if;
1554 -- Case of name present, in this case we expand raise name to
1556 -- Raise_Exception (name'Identity, location_string);
1558 -- where location_string identifies the file/line of the raise
1560 if Present (Name (N)) then
1561 declare
1562 Id : Entity_Id := Entity (Name (N));
1564 begin
1565 Name_Len := 0;
1566 Build_Location_String (Loc);
1568 -- If the exception is a renaming, use the exception that it
1569 -- renames (which might be a predefined exception, e.g.).
1571 if Present (Renamed_Object (Id)) then
1572 Id := Renamed_Object (Id);
1573 end if;
1575 -- Build a C-compatible string in case of no exception handlers,
1576 -- since this is what the last chance handler is expecting.
1578 if No_Exception_Handlers_Set then
1580 -- Generate an empty message if configuration pragma
1581 -- Suppress_Exception_Locations is set for this unit.
1583 if Opt.Exception_Locations_Suppressed then
1584 Name_Len := 1;
1585 else
1586 Name_Len := Name_Len + 1;
1587 end if;
1589 Name_Buffer (Name_Len) := ASCII.NUL;
1590 end if;
1592 if Opt.Exception_Locations_Suppressed then
1593 Name_Len := 0;
1594 end if;
1596 Str := String_From_Name_Buffer;
1598 -- For VMS exceptions, convert the raise into a call to
1599 -- lib$stop so it will be handled by __gnat_error_handler.
1601 if Is_VMS_Exception (Id) then
1602 declare
1603 Excep_Image : String_Id;
1604 Cond : Node_Id;
1606 begin
1607 if Present (Interface_Name (Id)) then
1608 Excep_Image := Strval (Interface_Name (Id));
1609 else
1610 Get_Name_String (Chars (Id));
1611 Set_All_Upper_Case;
1612 Excep_Image := String_From_Name_Buffer;
1613 end if;
1615 if Exception_Code (Id) /= No_Uint then
1616 Cond :=
1617 Make_Integer_Literal (Loc, Exception_Code (Id));
1618 else
1619 Cond :=
1620 Unchecked_Convert_To (Standard_Integer,
1621 Make_Function_Call (Loc,
1622 Name => New_Occurrence_Of
1623 (RTE (RE_Import_Value), Loc),
1624 Parameter_Associations => New_List
1625 (Make_String_Literal (Loc,
1626 Strval => Excep_Image))));
1627 end if;
1629 Rewrite (N,
1630 Make_Procedure_Call_Statement (Loc,
1631 Name =>
1632 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1633 Parameter_Associations => New_List (Cond)));
1634 Analyze_And_Resolve (Cond, Standard_Integer);
1635 end;
1637 -- Not VMS exception case, convert raise to call to the
1638 -- Raise_Exception routine.
1640 else
1641 Rewrite (N,
1642 Make_Procedure_Call_Statement (Loc,
1643 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1644 Parameter_Associations => New_List (
1645 Make_Attribute_Reference (Loc,
1646 Prefix => Name (N),
1647 Attribute_Name => Name_Identity),
1648 Make_String_Literal (Loc,
1649 Strval => Str))));
1650 end if;
1651 end;
1653 -- Case of no name present (reraise). We rewrite the raise to:
1655 -- Reraise_Occurrence_Always (EO);
1657 -- where EO is the current exception occurrence. If the current handler
1658 -- does not have a choice parameter specification, then we provide one.
1660 else
1661 -- Find innermost enclosing exception handler (there must be one,
1662 -- since the semantics has already verified that this raise statement
1663 -- is valid, and a raise with no arguments is only permitted in the
1664 -- context of an exception handler.
1666 Ehand := Parent (N);
1667 while Nkind (Ehand) /= N_Exception_Handler loop
1668 Ehand := Parent (Ehand);
1669 end loop;
1671 -- Make exception choice parameter if none present. Note that we do
1672 -- not need to put the entity on the entity chain, since no one will
1673 -- be referencing this entity by normal visibility methods.
1675 if No (Choice_Parameter (Ehand)) then
1676 E := Make_Temporary (Loc, 'E');
1677 Set_Choice_Parameter (Ehand, E);
1678 Set_Ekind (E, E_Variable);
1679 Set_Etype (E, RTE (RE_Exception_Occurrence));
1680 Set_Scope (E, Current_Scope);
1681 end if;
1683 -- Now rewrite the raise as a call to Reraise. A special case arises
1684 -- if this raise statement occurs in the context of a handler for
1685 -- all others (i.e. an at end handler). in this case we avoid
1686 -- the call to defer abort, cleanup routines are expected to be
1687 -- called in this case with aborts deferred.
1689 declare
1690 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1691 Ent : Entity_Id;
1693 begin
1694 if Nkind (Ech) = N_Others_Choice
1695 and then All_Others (Ech)
1696 then
1697 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1698 else
1699 Ent := RTE (RE_Reraise_Occurrence_Always);
1700 end if;
1702 Rewrite (N,
1703 Make_Procedure_Call_Statement (Loc,
1704 Name => New_Occurrence_Of (Ent, Loc),
1705 Parameter_Associations => New_List (
1706 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1707 end;
1708 end if;
1710 Analyze (N);
1711 end Expand_N_Raise_Statement;
1713 ----------------------------------
1714 -- Expand_N_Raise_Storage_Error --
1715 ----------------------------------
1717 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1718 begin
1719 -- We adjust the condition to deal with the C/Fortran boolean case. This
1720 -- may well not be necessary, as all such conditions are generated by
1721 -- the expander and probably are all standard boolean, but who knows
1722 -- what strange optimization in future may require this adjustment!
1724 Adjust_Condition (Condition (N));
1726 -- Now deal with possible local raise handling
1728 Possible_Local_Raise (N, Standard_Storage_Error);
1729 end Expand_N_Raise_Storage_Error;
1731 --------------------------
1732 -- Possible_Local_Raise --
1733 --------------------------
1735 procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1736 begin
1737 -- Nothing to do if local raise optimization not active
1739 if not Debug_Flag_Dot_G
1740 and then not Restriction_Active (No_Exception_Propagation)
1741 then
1742 return;
1743 end if;
1745 -- Nothing to do if original node was an explicit raise, because in
1746 -- that case, we already generated the required warning for the raise.
1748 if Nkind (Original_Node (N)) = N_Raise_Statement then
1749 return;
1750 end if;
1752 -- Otherwise see if we have a local handler for the exception
1754 declare
1755 H : constant Node_Id := Find_Local_Handler (E, N);
1757 begin
1758 -- If so, mark that it has a local raise
1760 if Present (H) then
1761 Set_Has_Local_Raise (H, True);
1763 -- Otherwise, if the No_Exception_Propagation restriction is active
1764 -- and the warning is enabled, generate the appropriate warnings.
1766 elsif Warn_On_Non_Local_Exception
1767 and then Restriction_Active (No_Exception_Propagation)
1768 then
1769 Warn_No_Exception_Propagation_Active (N);
1771 if Configurable_Run_Time_Mode then
1772 Error_Msg_NE
1773 ("\?& may call Last_Chance_Handler", N, E);
1774 else
1775 Error_Msg_NE
1776 ("\?& may result in unhandled exception", N, E);
1777 end if;
1778 end if;
1779 end;
1780 end Possible_Local_Raise;
1782 ------------------------------
1783 -- Expand_N_Subprogram_Info --
1784 ------------------------------
1786 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1787 Loc : constant Source_Ptr := Sloc (N);
1789 begin
1790 -- For now, we replace an Expand_N_Subprogram_Info node with an
1791 -- attribute reference that gives the address of the procedure.
1792 -- This is because gigi does not yet recognize this node, and
1793 -- for the initial targets, this is the right value anyway.
1795 Rewrite (N,
1796 Make_Attribute_Reference (Loc,
1797 Prefix => Identifier (N),
1798 Attribute_Name => Name_Code_Address));
1800 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1801 end Expand_N_Subprogram_Info;
1803 ------------------------
1804 -- Find_Local_Handler --
1805 ------------------------
1807 function Find_Local_Handler
1808 (Ename : Entity_Id;
1809 Nod : Node_Id) return Node_Id
1811 N : Node_Id;
1812 P : Node_Id;
1813 H : Node_Id;
1814 C : Node_Id;
1816 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1817 -- This is used to test for wrapped actions below
1819 ERaise : Entity_Id;
1820 EHandle : Entity_Id;
1821 -- The entity Id's for the exception we are raising and handling, using
1822 -- the renamed exception if a Renamed_Entity is present.
1824 begin
1825 -- Never any local handler if all handlers removed
1827 if Debug_Flag_Dot_X then
1828 return Empty;
1829 end if;
1831 -- Get the exception we are raising, allowing for renaming
1833 ERaise := Get_Renamed_Entity (Ename);
1835 -- We need to check if the node we are looking at is contained in
1838 -- Loop to search up the tree
1840 N := Nod;
1841 loop
1842 P := Parent (N);
1844 -- If we get to the top of the tree, or to a subprogram, task, entry,
1845 -- protected body, or accept statement without having found a
1846 -- matching handler, then there is no local handler.
1848 if No (P)
1849 or else Nkind (P) = N_Subprogram_Body
1850 or else Nkind (P) = N_Task_Body
1851 or else Nkind (P) = N_Protected_Body
1852 or else Nkind (P) = N_Entry_Body
1853 or else Nkind (P) = N_Accept_Statement
1854 then
1855 return Empty;
1857 -- Test for handled sequence of statements with at least one
1858 -- exception handler which might be the one we are looking for.
1860 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1861 and then Present (Exception_Handlers (P))
1862 then
1863 -- Before we proceed we need to check if the node N is covered
1864 -- by the statement part of P rather than one of its exception
1865 -- handlers (an exception handler obviously does not cover its
1866 -- own statements).
1868 -- This test is more delicate than might be thought. It is not
1869 -- just a matter of checking the Statements (P), because the node
1870 -- might be waiting to be wrapped in a transient scope, in which
1871 -- case it will end up in the block statements, even though it
1872 -- is not there now.
1874 if Is_List_Member (N)
1875 and then (List_Containing (N) = Statements (P)
1876 or else
1877 List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
1878 or else
1879 List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
1880 then
1881 -- Loop through exception handlers
1883 H := First (Exception_Handlers (P));
1884 while Present (H) loop
1886 -- Loop through choices in one handler
1888 C := First (Exception_Choices (H));
1889 while Present (C) loop
1891 -- Deal with others case
1893 if Nkind (C) = N_Others_Choice then
1895 -- Matching others handler, but we need to ensure
1896 -- there is no choice parameter. If there is, then we
1897 -- don't have a local handler after all (since we do
1898 -- not allow choice parameters for local handlers).
1900 if No (Choice_Parameter (H)) then
1901 return H;
1902 else
1903 return Empty;
1904 end if;
1906 -- If not others must be entity name
1908 elsif Nkind (C) /= N_Others_Choice then
1909 pragma Assert (Is_Entity_Name (C));
1910 pragma Assert (Present (Entity (C)));
1912 -- Get exception being handled, dealing with renaming
1914 EHandle := Get_Renamed_Entity (Entity (C));
1916 -- If match, then check choice parameter
1918 if ERaise = EHandle then
1919 if No (Choice_Parameter (H)) then
1920 return H;
1921 else
1922 return Empty;
1923 end if;
1924 end if;
1925 end if;
1927 Next (C);
1928 end loop;
1930 Next (H);
1931 end loop;
1932 end if;
1933 end if;
1935 N := P;
1936 end loop;
1937 end Find_Local_Handler;
1939 ---------------------------------
1940 -- Get_Local_Raise_Call_Entity --
1941 ---------------------------------
1943 -- Note: this is primary provided for use by the back end in generating
1944 -- calls to Local_Raise. But it would be too late in the back end to call
1945 -- RTE if this actually caused a load/analyze of the unit. So what we do
1946 -- is to ensure there is a dummy call to this function during front end
1947 -- processing so that the unit gets loaded then, and not later.
1949 Local_Raise_Call_Entity : Entity_Id;
1950 Local_Raise_Call_Entity_Set : Boolean := False;
1952 function Get_Local_Raise_Call_Entity return Entity_Id is
1953 begin
1954 if not Local_Raise_Call_Entity_Set then
1955 Local_Raise_Call_Entity_Set := True;
1957 if RTE_Available (RE_Local_Raise) then
1958 Local_Raise_Call_Entity := RTE (RE_Local_Raise);
1959 else
1960 Local_Raise_Call_Entity := Empty;
1961 end if;
1962 end if;
1964 return Local_Raise_Call_Entity;
1965 end Get_Local_Raise_Call_Entity;
1967 -----------------------------
1968 -- Get_RT_Exception_Entity --
1969 -----------------------------
1971 function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
1972 begin
1973 case R is
1974 when RT_CE_Exceptions => return Standard_Constraint_Error;
1975 when RT_PE_Exceptions => return Standard_Program_Error;
1976 when RT_SE_Exceptions => return Standard_Storage_Error;
1977 end case;
1978 end Get_RT_Exception_Entity;
1980 ----------------------
1981 -- Is_Non_Ada_Error --
1982 ----------------------
1984 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1985 begin
1986 if not OpenVMS_On_Target then
1987 return False;
1988 end if;
1990 Get_Name_String (Chars (E));
1992 -- Note: it is a little irregular for the body of exp_ch11 to know
1993 -- the details of the encoding scheme for names, but on the other
1994 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1996 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1997 return False;
1998 end if;
2000 return True;
2001 end Is_Non_Ada_Error;
2003 ----------------------------
2004 -- Warn_If_No_Propagation --
2005 ----------------------------
2007 procedure Warn_If_No_Propagation (N : Node_Id) is
2008 begin
2009 if Restriction_Check_Required (No_Exception_Propagation)
2010 and then Warn_On_Non_Local_Exception
2011 then
2012 Warn_No_Exception_Propagation_Active (N);
2014 if Configurable_Run_Time_Mode then
2015 Error_Msg_N
2016 ("\?Last_Chance_Handler will be called on exception", N);
2017 else
2018 Error_Msg_N
2019 ("\?execution may raise unhandled exception", N);
2020 end if;
2021 end if;
2022 end Warn_If_No_Propagation;
2024 ------------------------------------------
2025 -- Warn_No_Exception_Propagation_Active --
2026 ------------------------------------------
2028 procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
2029 begin
2030 Error_Msg_N
2031 ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
2032 end Warn_No_Exception_Propagation_Active;
2034 end Exp_Ch11;