]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C H 1 1 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
70482933 RK |
27 | with Debug; use Debug; |
28 | with Einfo; use Einfo; | |
baa3441d | 29 | with Elists; use Elists; |
07fc65c4 | 30 | with Errout; use Errout; |
70482933 | 31 | with Exp_Ch7; use Exp_Ch7; |
8f819471 | 32 | with Exp_Intr; use Exp_Intr; |
70482933 | 33 | with Exp_Util; use Exp_Util; |
70482933 RK |
34 | with Namet; use Namet; |
35 | with Nlists; use Nlists; | |
36 | with Nmake; use Nmake; | |
37 | with Opt; use Opt; | |
70482933 | 38 | with Restrict; use Restrict; |
6e937c1c | 39 | with Rident; use Rident; |
7340e432 | 40 | with Rtsfind; use Rtsfind; |
70482933 | 41 | with Sem; use Sem; |
70482933 RK |
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; | |
70482933 RK |
53 | |
54 | package body Exp_Ch11 is | |
55 | ||
baa3441d RD |
56 | ----------------------- |
57 | -- Local Subprograms -- | |
58 | ----------------------- | |
59 | ||
6c5290ce TQ |
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. | |
baa3441d RD |
64 | |
65 | procedure Warn_If_No_Propagation (N : Node_Id); | |
31fde973 GD |
66 | -- Called for an exception raise that is not a local raise (and thus cannot |
67 | -- 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. | |
baa3441d | 69 | |
70482933 RK |
70 | --------------------------- |
71 | -- Expand_At_End_Handler -- | |
72 | --------------------------- | |
73 | ||
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: | |
76 | ||
77 | -- exception | |
78 | -- when all others => | |
79 | -- cleanup call | |
80 | -- raise; | |
81 | ||
82 | -- Note: this exception handler is treated rather specially by | |
83 | -- subsequent expansion in two respects: | |
84 | ||
85 | -- The normal call to Undefer_Abort is omitted | |
86 | -- The raise call does not do Defer_Abort | |
87 | ||
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. | |
91 | ||
fbf5a39b AC |
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. | |
96 | ||
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. | |
101 | ||
6e840989 | 102 | procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is |
70482933 | 103 | Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); |
70482933 RK |
104 | Ohandle : Node_Id; |
105 | Stmnts : List_Id; | |
106 | ||
f849ad6f AC |
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. | |
114 | ||
70482933 RK |
115 | begin |
116 | pragma Assert (Present (Clean)); | |
117 | pragma Assert (No (Exception_Handlers (HSS))); | |
118 | ||
0ab0bf95 OH |
119 | -- Back end exception schemes don't need explicit handlers to |
120 | -- trigger AT-END actions on exceptional paths. | |
fbf5a39b | 121 | |
0ab0bf95 | 122 | if Back_End_Exceptions then |
fbf5a39b AC |
123 | return; |
124 | end if; | |
125 | ||
126 | -- Don't expand an At End handler if we have already had configurable | |
127 | -- run-time violations, since likely this will just be a matter of | |
128 | -- generating useless cascaded messages | |
129 | ||
130 | if Configurable_Run_Time_Violations > 0 then | |
131 | return; | |
132 | end if; | |
133 | ||
6c5290ce TQ |
134 | -- Don't expand an At End handler if we are not allowing exceptions |
135 | -- or if exceptions are transformed into local gotos, and never | |
136 | -- propagated (No_Exception_Propagation). | |
137 | ||
138 | if No_Exception_Handlers_Set then | |
70482933 RK |
139 | return; |
140 | end if; | |
141 | ||
6e840989 HK |
142 | if Present (Blk_Id) then |
143 | Push_Scope (Blk_Id); | |
70482933 RK |
144 | end if; |
145 | ||
146 | Ohandle := | |
147 | Make_Others_Choice (Loc); | |
148 | Set_All_Others (Ohandle); | |
149 | ||
150 | Stmnts := New_List ( | |
151 | Make_Procedure_Call_Statement (Loc, | |
f7d2a3f7 JM |
152 | Name => New_Occurrence_Of (Clean, Loc))); |
153 | ||
06eab6a7 RD |
154 | -- Generate reraise statement as last statement of AT-END handler, |
155 | -- unless we are under control of No_Exception_Propagation, in which | |
156 | -- case no exception propagation is possible anyway, so we do not need | |
157 | -- a reraise (the AT END handler in this case is only for normal exits | |
158 | -- not for exceptional exits). Also, we flag the Reraise statement as | |
159 | -- being part of an AT END handler to prevent signalling this reraise | |
160 | -- as a violation of the restriction when it is not set. | |
f7d2a3f7 JM |
161 | |
162 | if not Restriction_Active (No_Exception_Propagation) then | |
06eab6a7 RD |
163 | declare |
164 | Rstm : constant Node_Id := Make_Raise_Statement (Loc); | |
165 | begin | |
166 | Set_From_At_End (Rstm); | |
167 | Append_To (Stmnts, Rstm); | |
168 | end; | |
f7d2a3f7 | 169 | end if; |
70482933 RK |
170 | |
171 | Set_Exception_Handlers (HSS, New_List ( | |
baa3441d | 172 | Make_Implicit_Exception_Handler (Loc, |
70482933 RK |
173 | Exception_Choices => New_List (Ohandle), |
174 | Statements => Stmnts))); | |
175 | ||
176 | Analyze_List (Stmnts, Suppress => All_Checks); | |
177 | Expand_Exception_Handlers (HSS); | |
178 | ||
6e840989 | 179 | if Present (Blk_Id) then |
70482933 RK |
180 | Pop_Scope; |
181 | end if; | |
182 | end Expand_At_End_Handler; | |
183 | ||
70482933 RK |
184 | ------------------------------- |
185 | -- Expand_Exception_Handlers -- | |
186 | ------------------------------- | |
187 | ||
188 | procedure Expand_Exception_Handlers (HSS : Node_Id) is | |
baa3441d RD |
189 | Handlrs : constant List_Id := Exception_Handlers (HSS); |
190 | Loc : constant Source_Ptr := Sloc (HSS); | |
70482933 RK |
191 | Handler : Node_Id; |
192 | Others_Choice : Boolean; | |
193 | Obj_Decl : Node_Id; | |
baa3441d RD |
194 | Next_Handler : Node_Id; |
195 | ||
196 | procedure Expand_Local_Exception_Handlers; | |
197 | -- This procedure handles the expansion of exception handlers for the | |
198 | -- optimization of local raise statements into goto statements. | |
70482933 RK |
199 | |
200 | procedure Prepend_Call_To_Handler | |
201 | (Proc : RE_Id; | |
202 | Args : List_Id := No_List); | |
203 | -- Routine to prepend a call to the procedure referenced by Proc at | |
204 | -- the start of the handler code for the current Handler. | |
205 | ||
baa3441d RD |
206 | procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id); |
207 | -- Raise_S is a raise statement (possibly expanded, and possibly of the | |
208 | -- form of a Raise_xxx_Error node with a condition. This procedure is | |
209 | -- called to replace the raise action with the (already analyzed) goto | |
210 | -- statement passed as Goto_L1. This procedure also takes care of the | |
211 | -- requirement of inserting a Local_Raise call where possible. | |
212 | ||
213 | ------------------------------------- | |
214 | -- Expand_Local_Exception_Handlers -- | |
215 | ------------------------------------- | |
216 | ||
217 | -- There are two cases for this transformation. First the case of | |
218 | -- explicit raise statements. For this case, the transformation we do | |
6c5290ce | 219 | -- looks like this. Right now we have for example (where L1, L2 are |
baa3441d RD |
220 | -- exception labels) |
221 | ||
222 | -- begin | |
223 | -- ... | |
224 | -- raise_exception (excep1'identity); -- was raise excep1 | |
225 | -- ... | |
226 | -- raise_exception (excep2'identity); -- was raise excep2 | |
227 | -- ... | |
228 | -- exception | |
229 | -- when excep1 => | |
230 | -- estmts1 | |
231 | -- when excep2 => | |
232 | -- estmts2 | |
233 | -- end; | |
234 | ||
235 | -- This gets transformed into: | |
236 | ||
237 | -- begin | |
6c5290ce TQ |
238 | -- L1 : label; -- marked Exception_Junk |
239 | -- L2 : label; -- marked Exception_Junk | |
240 | -- L3 : label; -- marked Exception_Junk | |
baa3441d | 241 | |
6c5290ce | 242 | -- begin -- marked Exception_Junk |
baa3441d | 243 | -- ... |
6c5290ce | 244 | -- local_raise (excep1'address); -- was raise excep1 |
baa3441d RD |
245 | -- goto L1; |
246 | -- ... | |
6c5290ce | 247 | -- local_raise (excep2'address); -- was raise excep2 |
baa3441d RD |
248 | -- goto L2; |
249 | -- ... | |
250 | -- exception | |
251 | -- when excep1 => | |
252 | -- goto L1; | |
253 | -- when excep2 => | |
254 | -- goto L2; | |
255 | -- end; | |
256 | ||
6c5290ce | 257 | -- goto L3; -- skip handler if no raise, marked Exception_Junk |
baa3441d | 258 | |
6c5290ce TQ |
259 | -- <<L1>> -- local excep target label, marked Exception_Junk |
260 | -- begin -- marked Exception_Junk | |
261 | -- estmts1 | |
262 | -- end; | |
263 | -- goto L3; -- marked Exception_Junk | |
baa3441d | 264 | |
6c5290ce TQ |
265 | -- <<L2>> -- marked Exception_Junk |
266 | -- begin -- marked Exception_Junk | |
267 | -- estmts2 | |
268 | -- end; | |
269 | -- goto L3; -- marked Exception_Junk | |
270 | -- <<L3>> -- marked Exception_Junk | |
baa3441d RD |
271 | -- end; |
272 | ||
273 | -- Note: the reason we wrap the original statement sequence in an | |
274 | -- inner block is that there may be raise statements within the | |
275 | -- sequence of statements in the handlers, and we must ensure that | |
276 | -- these are properly handled, and in particular, such raise statements | |
277 | -- must not reenter the same exception handlers. | |
278 | ||
279 | -- If the restriction No_Exception_Propagation is in effect, then we | |
6c5290ce | 280 | -- can omit the exception handlers. |
baa3441d RD |
281 | |
282 | -- begin | |
6c5290ce TQ |
283 | -- L1 : label; -- marked Exception_Junk |
284 | -- L2 : label; -- marked Exception_Junk | |
285 | -- L3 : label; -- marked Exception_Junk | |
baa3441d | 286 | |
6c5290ce TQ |
287 | -- begin -- marked Exception_Junk |
288 | -- ... | |
289 | -- local_raise (excep1'address); -- was raise excep1 | |
290 | -- goto L1; | |
291 | -- ... | |
292 | -- local_raise (excep2'address); -- was raise excep2 | |
293 | -- goto L2; | |
294 | -- ... | |
295 | -- end; | |
baa3441d | 296 | |
6c5290ce | 297 | -- goto L3; -- skip handler if no raise, marked Exception_Junk |
baa3441d | 298 | |
6c5290ce TQ |
299 | -- <<L1>> -- local excep target label, marked Exception_Junk |
300 | -- begin -- marked Exception_Junk | |
301 | -- estmts1 | |
302 | -- end; | |
303 | -- goto L3; -- marked Exception_Junk | |
baa3441d | 304 | |
6c5290ce TQ |
305 | -- <<L2>> -- marked Exception_Junk |
306 | -- begin -- marked Exception_Junk | |
307 | -- estmts2 | |
308 | -- end; | |
309 | ||
310 | -- <<L3>> -- marked Exception_Junk | |
baa3441d RD |
311 | -- end; |
312 | ||
313 | -- The second case is for exceptions generated by the back end in one | |
314 | -- of three situations: | |
315 | ||
316 | -- 1. Front end generates N_Raise_xxx_Error node | |
317 | -- 2. Front end sets Do_xxx_Check flag in subexpression node | |
318 | -- 3. Back end detects a situation where an exception is appropriate | |
319 | ||
320 | -- In all these cases, the current processing in gigi is to generate a | |
321 | -- call to the appropriate Rcheck_xx routine (where xx encodes both the | |
322 | -- exception message and the exception to be raised, Constraint_Error, | |
323 | -- Program_Error, or Storage_Error. | |
324 | ||
325 | -- We could handle some subcases of 1 using the same front end expansion | |
326 | -- into gotos, but even for case 1, we can't handle all cases, since | |
327 | -- generating gotos in the middle of expressions is not possible (it's | |
328 | -- possible at the gigi/gcc level, but not at the level of the GNAT | |
329 | -- tree). | |
330 | ||
331 | -- In any case, it seems easier to have a scheme which handles all three | |
332 | -- cases in a uniform manner. So here is how we proceed in this case. | |
333 | ||
334 | -- This procedure detects all handlers for these three exceptions, | |
335 | -- Constraint_Error, Program_Error and Storage_Error (including WHEN | |
336 | -- OTHERS handlers that cover one or more of these cases). | |
337 | ||
338 | -- If the handler meets the requirements for being the target of a local | |
339 | -- raise, then the front end does the expansion described previously, | |
340 | -- creating a label to be used as a goto target to raise the exception. | |
341 | -- However, no attempt is made in the front end to convert any related | |
6c5290ce TQ |
342 | -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are |
343 | -- left unchanged and passed to the back end. | |
baa3441d | 344 | |
1adaea16 | 345 | -- Instead, the front end generates three nodes |
baa3441d RD |
346 | |
347 | -- N_Push_Constraint_Error_Label | |
348 | -- N_Push_Program_Error_Label | |
349 | -- N_Push_Storage_Error_Label | |
350 | ||
351 | -- The Push node is generated at the start of the statements | |
352 | -- covered by the handler, and has as a parameter the label to be | |
353 | -- used as the raise target. | |
354 | ||
355 | -- N_Pop_Constraint_Error_Label | |
356 | -- N_Pop_Program_Error_Label | |
357 | -- N_Pop_Storage_Error_Label | |
358 | ||
359 | -- The Pop node is generated at the end of the covered statements | |
360 | -- and undoes the effect of the preceding corresponding Push node. | |
361 | ||
362 | -- In the case where the handler does NOT meet the requirements, the | |
363 | -- front end will still generate the Push and Pop nodes, but the label | |
364 | -- field in the Push node will be empty signifying that for this region | |
365 | -- of code, no optimization is possible. | |
366 | ||
1adaea16 AC |
367 | -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set |
368 | -- since they are useless in this case, and in CodePeer mode, where | |
369 | -- they serve no purpose and can intefere with the analysis. | |
370 | ||
baa3441d | 371 | -- The back end must maintain three stacks, one for each exception case, |
6c5290ce | 372 | -- the Push node pushes an entry onto the corresponding stack, and Pop |
baa3441d RD |
373 | -- node pops off the entry. Then instead of calling Rcheck_nn, if the |
374 | -- corresponding top stack entry has an non-empty label, a goto is | |
6c5290ce TQ |
375 | -- generated. This goto should be preceded by a call to Local_Raise as |
376 | -- described above. | |
baa3441d RD |
377 | |
378 | -- An example of this transformation is as follows, given: | |
379 | ||
380 | -- declare | |
381 | -- A : Integer range 1 .. 10; | |
382 | -- begin | |
383 | -- A := B + C; | |
384 | -- exception | |
385 | -- when Constraint_Error => | |
386 | -- estmts | |
387 | -- end; | |
388 | ||
389 | -- gets transformed to: | |
390 | ||
391 | -- declare | |
392 | -- A : Integer range 1 .. 10; | |
393 | ||
394 | -- begin | |
395 | -- L1 : label; | |
396 | -- L2 : label; | |
397 | ||
398 | -- begin | |
6c5290ce TQ |
399 | -- %push_constraint_error_label (L1) |
400 | -- R1b : constant long_long_integer := long_long_integer?(b) + | |
401 | -- long_long_integer?(c); | |
402 | -- [constraint_error when | |
403 | -- not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#) | |
404 | -- "overflow check failed"] | |
baa3441d RD |
405 | -- a := integer?(R1b); |
406 | -- %pop_constraint_error_Label | |
407 | ||
408 | -- exception | |
409 | -- ... | |
410 | -- when constraint_error => | |
411 | -- goto L1; | |
412 | -- end; | |
413 | ||
414 | -- goto L2; -- skip handler when exception not raised | |
415 | -- <<L1>> -- target label for local exception | |
416 | -- estmts | |
417 | -- <<L2>> | |
418 | -- end; | |
419 | ||
6c5290ce TQ |
420 | -- Note: the generated labels and goto statements all have the flag |
421 | -- Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore | |
422 | -- this generated exception stuff when checking for missing return | |
423 | -- statements (see circuitry in Check_Statement_Sequence). | |
424 | ||
425 | -- Note: All of the processing described above occurs only if | |
426 | -- restriction No_Exception_Propagation applies or debug flag .g is | |
427 | -- enabled. | |
428 | ||
baa3441d RD |
429 | CE_Locally_Handled : Boolean := False; |
430 | SE_Locally_Handled : Boolean := False; | |
431 | PE_Locally_Handled : Boolean := False; | |
432 | -- These three flags indicate whether a handler for the corresponding | |
433 | -- exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error) | |
434 | -- is present. If so the switch is set to True, the Exception_Label | |
435 | -- field of the corresponding handler is set, and appropriate Push | |
436 | -- and Pop nodes are inserted into the code. | |
437 | ||
438 | Local_Expansion_Required : Boolean := False; | |
439 | -- Set True if we have at least one handler requiring local raise | |
440 | -- expansion as described above. | |
441 | ||
442 | procedure Expand_Local_Exception_Handlers is | |
baa3441d RD |
443 | procedure Add_Exception_Label (H : Node_Id); |
444 | -- H is an exception handler. First check for an Exception_Label | |
6c5290ce | 445 | -- already allocated for H. If none, allocate one, set the field in |
baa3441d | 446 | -- the handler node, add the label declaration, and set the flag |
6c5290ce | 447 | -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set |
baa3441d RD |
448 | -- the call has no effect and Exception_Label is left empty. |
449 | ||
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. | |
453 | ||
454 | generic | |
455 | Exc_Locally_Handled : in out Boolean; | |
456 | -- Flag indicating whether a local handler for this exception | |
457 | -- has already been generated. | |
458 | ||
459 | with function Make_Push_Label (Loc : Source_Ptr) return Node_Id; | |
460 | -- Function to create a Push_xxx_Label node | |
461 | ||
462 | with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id; | |
463 | -- Function to create a Pop_xxx_Label node | |
464 | ||
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. | |
469 | ||
470 | ------------------------- | |
471 | -- Add_Exception_Label -- | |
472 | ------------------------- | |
473 | ||
474 | procedure Add_Exception_Label (H : Node_Id) is | |
475 | begin | |
476 | if No (Exception_Label (H)) | |
477 | and then not Local_Raise_Not_OK (H) | |
6c5290ce | 478 | and then not Special_Exception_Package_Used |
baa3441d RD |
479 | then |
480 | Local_Expansion_Required := True; | |
481 | ||
482 | declare | |
191fcb3a | 483 | L : constant Entity_Id := Make_Temporary (Sloc (H), 'L'); |
baa3441d RD |
484 | begin |
485 | Set_Exception_Label (H, L); | |
486 | Add_Label_Declaration (L); | |
487 | end; | |
488 | end if; | |
489 | end Add_Exception_Label; | |
490 | ||
491 | --------------------------- | |
492 | -- Add_Label_Declaration -- | |
493 | --------------------------- | |
494 | ||
495 | procedure Add_Label_Declaration (L : Entity_Id) is | |
496 | P : constant Node_Id := Parent (HSS); | |
497 | ||
498 | Decl_L : constant Node_Id := | |
499 | Make_Implicit_Label_Declaration (Loc, | |
500 | Defining_Identifier => L); | |
501 | ||
502 | begin | |
503 | if Declarations (P) = No_List then | |
504 | Set_Declarations (P, Empty_List); | |
505 | end if; | |
506 | ||
507 | Append (Decl_L, Declarations (P)); | |
508 | Analyze (Decl_L); | |
509 | end Add_Label_Declaration; | |
510 | ||
511 | ----------------------- | |
512 | -- Generate_Push_Pop -- | |
513 | ----------------------- | |
514 | ||
515 | procedure Generate_Push_Pop (H : Node_Id) is | |
516 | begin | |
1adaea16 AC |
517 | if Restriction_Active (No_Exception_Handlers) |
518 | or else CodePeer_Mode | |
519 | then | |
520 | return; | |
521 | end if; | |
522 | ||
baa3441d RD |
523 | if Exc_Locally_Handled then |
524 | return; | |
525 | else | |
526 | Exc_Locally_Handled := True; | |
527 | end if; | |
528 | ||
529 | Add_Exception_Label (H); | |
530 | ||
531 | declare | |
532 | F : constant Node_Id := First (Statements (HSS)); | |
533 | L : constant Node_Id := Last (Statements (HSS)); | |
534 | ||
535 | Push : constant Node_Id := Make_Push_Label (Sloc (F)); | |
536 | Pop : constant Node_Id := Make_Pop_Label (Sloc (L)); | |
537 | ||
538 | begin | |
6c5290ce TQ |
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. | |
baa3441d | 542 | |
6c5290ce TQ |
543 | Discard_Node (Get_Local_Raise_Call_Entity); |
544 | ||
545 | -- Prepare and insert Push and Pop nodes | |
546 | ||
547 | Set_Exception_Label (Push, Exception_Label (H)); | |
baa3441d RD |
548 | Insert_Before (F, Push); |
549 | Set_Analyzed (Push); | |
550 | ||
551 | Insert_After (L, Pop); | |
552 | Set_Analyzed (Pop); | |
553 | end; | |
554 | end Generate_Push_Pop; | |
555 | ||
556 | -- Local declarations | |
557 | ||
558 | Loc : constant Source_Ptr := Sloc (HSS); | |
6c5290ce | 559 | Stmts : List_Id := No_List; |
baa3441d | 560 | Choice : Node_Id; |
6c5290ce | 561 | Excep : Entity_Id; |
baa3441d RD |
562 | |
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. | |
572 | ||
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. | |
582 | ||
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. | |
592 | ||
6c5290ce TQ |
593 | -- Start of processing for Expand_Local_Exception_Handlers |
594 | ||
baa3441d | 595 | begin |
6c5290ce TQ |
596 | -- No processing if all exception handlers will get removed |
597 | ||
598 | if Debug_Flag_Dot_X then | |
599 | return; | |
600 | end if; | |
601 | ||
602 | -- See for each handler if we have any local raises to expand | |
baa3441d RD |
603 | |
604 | Handler := First_Non_Pragma (Handlrs); | |
605 | while Present (Handler) loop | |
606 | ||
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. | |
611 | ||
612 | if Present (Local_Raise_Statements (Handler)) then | |
613 | Add_Exception_Label (Handler); | |
614 | end if; | |
615 | ||
616 | -- If we are doing local raise to goto optimization (restriction | |
617 | -- No_Exception_Propagation set or debug flag .g set), then check | |
6c5290ce TQ |
618 | -- to see if handler handles CE, PE, SE and if so generate the |
619 | -- appropriate push/pop sequence for the back end. | |
baa3441d | 620 | |
6c5290ce TQ |
621 | if (Debug_Flag_Dot_G |
622 | or else Restriction_Active (No_Exception_Propagation)) | |
623 | and then Has_Local_Raise (Handler) | |
baa3441d RD |
624 | then |
625 | Choice := First (Exception_Choices (Handler)); | |
626 | while Present (Choice) loop | |
6c5290ce TQ |
627 | if Nkind (Choice) = N_Others_Choice |
628 | and then not All_Others (Choice) | |
629 | then | |
baa3441d RD |
630 | Generate_Push_Pop_For_Constraint_Error (Handler); |
631 | Generate_Push_Pop_For_Program_Error (Handler); | |
632 | Generate_Push_Pop_For_Storage_Error (Handler); | |
633 | ||
634 | elsif Is_Entity_Name (Choice) then | |
6c5290ce TQ |
635 | Excep := Get_Renamed_Entity (Entity (Choice)); |
636 | ||
637 | if Excep = Standard_Constraint_Error then | |
baa3441d | 638 | Generate_Push_Pop_For_Constraint_Error (Handler); |
6c5290ce TQ |
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); | |
baa3441d RD |
643 | end if; |
644 | end if; | |
645 | ||
646 | Next (Choice); | |
647 | end loop; | |
648 | end if; | |
649 | ||
650 | Next_Non_Pragma (Handler); | |
651 | end loop; | |
652 | ||
653 | -- Nothing to do if no handlers requiring the goto transformation | |
654 | ||
655 | if not (Local_Expansion_Required) then | |
656 | return; | |
657 | end if; | |
658 | ||
659 | -- Prepare to do the transformation | |
660 | ||
661 | declare | |
6c5290ce TQ |
662 | -- L3 is the label to exit the HSS |
663 | ||
191fcb3a | 664 | L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L'); |
baa3441d RD |
665 | |
666 | Labl_L3 : constant Node_Id := | |
667 | Make_Label (Loc, | |
668 | Identifier => New_Occurrence_Of (L3_Dent, Loc)); | |
669 | ||
baa3441d RD |
670 | Blk_Stm : Node_Id; |
671 | Relmt : Elmt_Id; | |
672 | ||
673 | begin | |
6c5290ce | 674 | Set_Exception_Junk (Labl_L3); |
baa3441d RD |
675 | Add_Label_Declaration (L3_Dent); |
676 | ||
6c5290ce | 677 | -- Wrap existing statements and handlers in an inner block |
baa3441d | 678 | |
6c5290ce TQ |
679 | Blk_Stm := |
680 | Make_Block_Statement (Loc, | |
681 | Handled_Statement_Sequence => Relocate_Node (HSS)); | |
682 | Set_Exception_Junk (Blk_Stm); | |
baa3441d | 683 | |
6c5290ce TQ |
684 | Rewrite (HSS, |
685 | Make_Handled_Sequence_Of_Statements (Loc, | |
0eed45bb AC |
686 | Statements => New_List (Blk_Stm), |
687 | End_Label => Relocate_Node (End_Label (HSS)))); | |
baa3441d | 688 | |
6c5290ce TQ |
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. | |
baa3441d | 692 | |
6c5290ce | 693 | Set_Analyzed (Blk_Stm); |
baa3441d RD |
694 | |
695 | -- Now loop through the exception handlers to deal with those that | |
696 | -- are targets of local raise statements. | |
697 | ||
698 | Handler := First_Non_Pragma (Handlrs); | |
699 | while Present (Handler) loop | |
700 | if Present (Exception_Label (Handler)) then | |
701 | ||
702 | -- This handler needs the goto expansion | |
703 | ||
704 | declare | |
705 | Loc : constant Source_Ptr := Sloc (Handler); | |
706 | ||
6c5290ce TQ |
707 | -- L1 is the start label for this handler |
708 | ||
baa3441d RD |
709 | L1_Dent : constant Entity_Id := Exception_Label (Handler); |
710 | ||
711 | Labl_L1 : constant Node_Id := | |
712 | Make_Label (Loc, | |
713 | Identifier => | |
714 | New_Occurrence_Of (L1_Dent, Loc)); | |
715 | ||
6c5290ce TQ |
716 | -- Jump to L1 to be used as replacement for the original |
717 | -- handler (used in the case where exception propagation | |
718 | -- may still occur). | |
719 | ||
baa3441d RD |
720 | Name_L1 : constant Node_Id := |
721 | New_Occurrence_Of (L1_Dent, Loc); | |
722 | ||
723 | Goto_L1 : constant Node_Id := | |
724 | Make_Goto_Statement (Loc, | |
725 | Name => Name_L1); | |
726 | ||
6c5290ce TQ |
727 | -- Jump to L3 to be used at the end of handler |
728 | ||
baa3441d RD |
729 | Name_L3 : constant Node_Id := |
730 | New_Occurrence_Of (L3_Dent, Loc); | |
731 | ||
732 | Goto_L3 : constant Node_Id := | |
733 | Make_Goto_Statement (Loc, | |
734 | Name => Name_L3); | |
735 | ||
736 | H_Stmts : constant List_Id := Statements (Handler); | |
737 | ||
738 | begin | |
6c5290ce TQ |
739 | Set_Exception_Junk (Labl_L1); |
740 | Set_Exception_Junk (Goto_L3); | |
741 | ||
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. | |
745 | ||
baa3441d RD |
746 | -- Replace handler by a goto L1. We can mark this as |
747 | -- analyzed since it is fully formed, and we don't | |
6c5290ce TQ |
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. | |
baa3441d RD |
751 | |
752 | Set_Statements (Handler, New_List (Goto_L1)); | |
753 | Set_Analyzed (Goto_L1); | |
754 | Set_Etype (Name_L1, Standard_Void_Type); | |
755 | ||
756 | -- Now replace all the raise statements by goto L1 | |
757 | ||
758 | if Present (Local_Raise_Statements (Handler)) then | |
759 | Relmt := First_Elmt (Local_Raise_Statements (Handler)); | |
760 | while Present (Relmt) loop | |
761 | declare | |
0eed45bb AC |
762 | Raise_S : constant Node_Id := Node (Relmt); |
763 | RLoc : constant Source_Ptr := Sloc (Raise_S); | |
baa3441d RD |
764 | Name_L1 : constant Node_Id := |
765 | New_Occurrence_Of (L1_Dent, Loc); | |
baa3441d | 766 | Goto_L1 : constant Node_Id := |
0eed45bb | 767 | Make_Goto_Statement (RLoc, |
baa3441d RD |
768 | Name => Name_L1); |
769 | ||
770 | begin | |
771 | -- Replace raise by goto L1 | |
772 | ||
773 | Set_Analyzed (Goto_L1); | |
774 | Set_Etype (Name_L1, Standard_Void_Type); | |
775 | Replace_Raise_By_Goto (Raise_S, Goto_L1); | |
776 | end; | |
777 | ||
778 | Next_Elmt (Relmt); | |
779 | end loop; | |
780 | end if; | |
781 | ||
6c5290ce | 782 | -- Add a goto L3 at end of statement list in block. The |
baa3441d RD |
783 | -- first time, this is what skips over the exception |
784 | -- handlers in the normal case. Subsequent times, it | |
6c5290ce TQ |
785 | -- terminates the execution of the previous handler code, |
786 | -- and skips subsequent handlers. | |
baa3441d RD |
787 | |
788 | Stmts := Statements (HSS); | |
789 | ||
790 | Insert_After (Last (Stmts), Goto_L3); | |
791 | Set_Analyzed (Goto_L3); | |
792 | Set_Etype (Name_L3, Standard_Void_Type); | |
793 | ||
794 | -- Now we drop the label that marks the handler start, | |
795 | -- followed by the statements of the handler. | |
796 | ||
797 | Set_Etype (Identifier (Labl_L1), Standard_Void_Type); | |
798 | ||
799 | Insert_After_And_Analyze (Last (Stmts), Labl_L1); | |
6c5290ce TQ |
800 | |
801 | declare | |
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)); | |
808 | begin | |
809 | Set_Exception_Junk (Blk); | |
810 | Insert_After_And_Analyze (Last (Stmts), Blk); | |
811 | end; | |
baa3441d RD |
812 | end; |
813 | ||
814 | -- Here if we have local raise statements but the handler is | |
815 | -- not suitable for processing with a local raise. In this | |
6c5290ce | 816 | -- case we have to generate possible diagnostics. |
baa3441d | 817 | |
6c5290ce TQ |
818 | elsif Has_Local_Raise (Handler) |
819 | and then Local_Raise_Statements (Handler) /= No_Elist | |
820 | then | |
baa3441d RD |
821 | Relmt := First_Elmt (Local_Raise_Statements (Handler)); |
822 | while Present (Relmt) loop | |
823 | Warn_If_No_Propagation (Node (Relmt)); | |
baa3441d RD |
824 | Next_Elmt (Relmt); |
825 | end loop; | |
826 | end if; | |
827 | ||
828 | Next (Handler); | |
829 | end loop; | |
830 | ||
831 | -- Only remaining step is to drop the L3 label and we are done | |
832 | ||
833 | Set_Etype (Identifier (Labl_L3), Standard_Void_Type); | |
6c5290ce TQ |
834 | |
835 | -- If we had at least one handler, then we drop the label after | |
836 | -- the last statement of that handler. | |
837 | ||
838 | if Stmts /= No_List then | |
839 | Insert_After_And_Analyze (Last (Stmts), Labl_L3); | |
840 | ||
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. | |
844 | ||
845 | else | |
846 | Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3); | |
847 | end if; | |
848 | ||
baa3441d RD |
849 | return; |
850 | end; | |
851 | end Expand_Local_Exception_Handlers; | |
852 | ||
07fc65c4 GB |
853 | ----------------------------- |
854 | -- Prepend_Call_To_Handler -- | |
855 | ----------------------------- | |
856 | ||
70482933 RK |
857 | procedure Prepend_Call_To_Handler |
858 | (Proc : RE_Id; | |
859 | Args : List_Id := No_List) | |
860 | is | |
07fc65c4 | 861 | Ent : constant Entity_Id := RTE (Proc); |
70482933 RK |
862 | |
863 | begin | |
beb50807 AC |
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. | |
07fc65c4 GB |
868 | |
869 | if Present (Ent) then | |
870 | declare | |
871 | Call : constant Node_Id := | |
beb50807 AC |
872 | Make_Procedure_Call_Statement (No_Location, |
873 | Name => New_Occurrence_Of (RTE (Proc), No_Location), | |
07fc65c4 GB |
874 | Parameter_Associations => Args); |
875 | ||
876 | begin | |
877 | Prepend_To (Statements (Handler), Call); | |
878 | Analyze (Call, Suppress => All_Checks); | |
879 | end; | |
880 | end if; | |
70482933 RK |
881 | end Prepend_Call_To_Handler; |
882 | ||
baa3441d RD |
883 | --------------------------- |
884 | -- Replace_Raise_By_Goto -- | |
885 | --------------------------- | |
886 | ||
887 | procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is | |
888 | Loc : constant Source_Ptr := Sloc (Raise_S); | |
889 | Excep : Entity_Id; | |
890 | LR : Node_Id; | |
891 | Cond : Node_Id; | |
892 | Orig : Node_Id; | |
893 | ||
894 | begin | |
895 | -- If we have a null statement, it means that there is no replacement | |
896 | -- needed (typically this results from a suppressed check). | |
897 | ||
898 | if Nkind (Raise_S) = N_Null_Statement then | |
899 | return; | |
900 | ||
901 | -- Test for Raise_xxx_Error | |
902 | ||
903 | elsif Nkind (Raise_S) = N_Raise_Constraint_Error then | |
904 | Excep := Standard_Constraint_Error; | |
905 | Cond := Condition (Raise_S); | |
906 | ||
907 | elsif Nkind (Raise_S) = N_Raise_Storage_Error then | |
908 | Excep := Standard_Storage_Error; | |
909 | Cond := Condition (Raise_S); | |
910 | ||
911 | elsif Nkind (Raise_S) = N_Raise_Program_Error then | |
912 | Excep := Standard_Program_Error; | |
913 | Cond := Condition (Raise_S); | |
914 | ||
6c5290ce | 915 | -- The only other possibility is a node that is or used to be a |
6778c2ca HK |
916 | -- simple raise statement. Note that the string expression in the |
917 | -- original Raise statement is ignored. | |
baa3441d RD |
918 | |
919 | else | |
920 | Orig := Original_Node (Raise_S); | |
921 | pragma Assert (Nkind (Orig) = N_Raise_Statement | |
b23fa3d4 | 922 | and then Present (Name (Orig))); |
baa3441d RD |
923 | Excep := Entity (Name (Orig)); |
924 | Cond := Empty; | |
925 | end if; | |
926 | ||
927 | -- Here Excep is the exception to raise, and Cond is the condition | |
6c5290ce | 928 | -- First prepare the call to Local_Raise (excep'address). |
baa3441d RD |
929 | |
930 | if RTE_Available (RE_Local_Raise) then | |
931 | LR := | |
932 | Make_Procedure_Call_Statement (Loc, | |
933 | Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc), | |
934 | Parameter_Associations => New_List ( | |
6c5290ce TQ |
935 | Unchecked_Convert_To (RTE (RE_Address), |
936 | Make_Attribute_Reference (Loc, | |
937 | Prefix => New_Occurrence_Of (Excep, Loc), | |
938 | Attribute_Name => Name_Identity)))); | |
baa3441d RD |
939 | |
940 | -- Use null statement if Local_Raise not available | |
941 | ||
942 | else | |
943 | LR := | |
944 | Make_Null_Statement (Loc); | |
945 | end if; | |
946 | ||
947 | -- If there is no condition, we rewrite as | |
948 | ||
949 | -- begin | |
950 | -- Local_Raise (excep'Identity); | |
951 | -- goto L1; | |
952 | -- end; | |
953 | ||
954 | if No (Cond) then | |
955 | Rewrite (Raise_S, | |
956 | Make_Block_Statement (Loc, | |
957 | Handled_Statement_Sequence => | |
958 | Make_Handled_Sequence_Of_Statements (Loc, | |
959 | Statements => New_List (LR, Goto_L1)))); | |
6c5290ce | 960 | Set_Exception_Junk (Raise_S); |
baa3441d RD |
961 | |
962 | -- If there is a condition, we rewrite as | |
963 | ||
964 | -- if condition then | |
965 | -- Local_Raise (excep'Identity); | |
966 | -- goto L1; | |
967 | -- end if; | |
968 | ||
969 | else | |
970 | Rewrite (Raise_S, | |
971 | Make_If_Statement (Loc, | |
972 | Condition => Cond, | |
973 | Then_Statements => New_List (LR, Goto_L1))); | |
974 | end if; | |
975 | ||
976 | Analyze (Raise_S); | |
977 | end Replace_Raise_By_Goto; | |
978 | ||
70482933 RK |
979 | -- Start of processing for Expand_Exception_Handlers |
980 | ||
981 | begin | |
baa3441d RD |
982 | Expand_Local_Exception_Handlers; |
983 | ||
70482933 RK |
984 | -- Loop through handlers |
985 | ||
986 | Handler := First_Non_Pragma (Handlrs); | |
fbf5a39b | 987 | Handler_Loop : while Present (Handler) loop |
2ba7e31e AC |
988 | Process_Statements_For_Controlled_Objects (Handler); |
989 | ||
baa3441d | 990 | Next_Handler := Next_Non_Pragma (Handler); |
70482933 | 991 | |
06eab6a7 | 992 | -- Remove source handler if gnat debug flag .x is set |
fbf5a39b AC |
993 | |
994 | if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then | |
baa3441d | 995 | Remove (Handler); |
70482933 | 996 | |
baa3441d RD |
997 | -- Remove handler if no exception propagation, generating a warning |
998 | -- if a source generated handler was not the target of a local raise. | |
70482933 | 999 | |
06eab6a7 | 1000 | else |
8f8f531f | 1001 | if not Has_Local_Raise (Handler) |
baa3441d | 1002 | and then Comes_From_Source (Handler) |
baa3441d | 1003 | then |
8f8f531f | 1004 | Warn_If_No_Local_Raise (Handler); |
baa3441d | 1005 | end if; |
70482933 | 1006 | |
06eab6a7 RD |
1007 | if No_Exception_Propagation_Active then |
1008 | Remove (Handler); | |
70482933 | 1009 | |
06eab6a7 | 1010 | -- Exception handler is active and retained and must be processed |
70482933 | 1011 | |
06eab6a7 RD |
1012 | else |
1013 | -- If an exception occurrence is present, then we must declare | |
1014 | -- it and initialize it from the value stored in the TSD | |
70482933 | 1015 | |
06eab6a7 RD |
1016 | -- declare |
1017 | -- name : Exception_Occurrence; | |
1018 | -- begin | |
1019 | -- Save_Occurrence (name, Get_Current_Excep.all) | |
1020 | -- ... | |
1021 | -- end; | |
baa3441d | 1022 | |
0ab0bf95 OH |
1023 | -- This expansion is only performed when using front-end |
1024 | -- exceptions. Gigi will insert a call to initialize the | |
1025 | -- choice parameter. | |
e74d643a AC |
1026 | |
1027 | if Present (Choice_Parameter (Handler)) | |
0ab0bf95 | 1028 | and then (Front_End_Exceptions |
99f97947 | 1029 | or else CodePeer_Mode) |
e74d643a | 1030 | then |
06eab6a7 RD |
1031 | declare |
1032 | Cparm : constant Entity_Id := Choice_Parameter (Handler); | |
8b4261b3 AC |
1033 | Cloc : constant Source_Ptr := Sloc (Cparm); |
1034 | Hloc : constant Source_Ptr := Sloc (Handler); | |
06eab6a7 | 1035 | Save : Node_Id; |
baa3441d | 1036 | |
06eab6a7 | 1037 | begin |
99f97947 AC |
1038 | -- Note: No_Location used to hide code from the debugger, |
1039 | -- so single stepping doesn't jump back and forth. | |
beb50807 | 1040 | |
06eab6a7 | 1041 | Save := |
beb50807 | 1042 | Make_Procedure_Call_Statement (No_Location, |
808876a9 | 1043 | Name => |
6d9e03cb AC |
1044 | New_Occurrence_Of |
1045 | (RTE (RE_Save_Occurrence), No_Location), | |
06eab6a7 | 1046 | Parameter_Associations => New_List ( |
6d9e03cb | 1047 | New_Occurrence_Of (Cparm, No_Location), |
beb50807 | 1048 | Make_Explicit_Dereference (No_Location, |
99f97947 AC |
1049 | Prefix => |
1050 | Make_Function_Call (No_Location, | |
1051 | Name => | |
1052 | Make_Explicit_Dereference (No_Location, | |
1053 | Prefix => | |
1054 | New_Occurrence_Of | |
1055 | (RTE (RE_Get_Current_Excep), | |
1056 | No_Location)))))); | |
06eab6a7 RD |
1057 | |
1058 | Mark_Rewrite_Insertion (Save); | |
1059 | Prepend (Save, Statements (Handler)); | |
1060 | ||
1061 | Obj_Decl := | |
808876a9 RD |
1062 | Make_Object_Declaration (Cloc, |
1063 | Defining_Identifier => Cparm, | |
1064 | Object_Definition => | |
1065 | New_Occurrence_Of | |
1066 | (RTE (RE_Exception_Occurrence), Cloc)); | |
06eab6a7 RD |
1067 | Set_No_Initialization (Obj_Decl, True); |
1068 | ||
1069 | Rewrite (Handler, | |
8b4261b3 AC |
1070 | Make_Exception_Handler (Hloc, |
1071 | Choice_Parameter => Empty, | |
06eab6a7 | 1072 | Exception_Choices => Exception_Choices (Handler), |
808876a9 | 1073 | Statements => New_List ( |
8b4261b3 | 1074 | Make_Block_Statement (Hloc, |
06eab6a7 RD |
1075 | Declarations => New_List (Obj_Decl), |
1076 | Handled_Statement_Sequence => | |
8b4261b3 | 1077 | Make_Handled_Sequence_Of_Statements (Hloc, |
06eab6a7 RD |
1078 | Statements => Statements (Handler)))))); |
1079 | ||
8b4261b3 AC |
1080 | -- Local raise statements can't occur, since exception |
1081 | -- handlers with choice parameters are not allowed when | |
1082 | -- No_Exception_Propagation applies, so set attributes | |
1083 | -- accordingly. | |
1084 | ||
1085 | Set_Local_Raise_Statements (Handler, No_Elist); | |
1086 | Set_Local_Raise_Not_OK (Handler); | |
1087 | ||
06eab6a7 RD |
1088 | Analyze_List |
1089 | (Statements (Handler), Suppress => All_Checks); | |
1090 | end; | |
1091 | end if; | |
baa3441d | 1092 | |
535a8637 AC |
1093 | -- For the normal case, we have to worry about the state of |
1094 | -- abort deferral. Generally, we defer abort during runtime | |
1095 | -- handling of exceptions. When control is passed to the | |
1096 | -- handler, then in the normal case we undefer aborts. In | |
1097 | -- any case this entire handling is relevant only if aborts | |
1098 | -- are allowed. | |
1099 | ||
1100 | if Abort_Allowed | |
0ab0bf95 | 1101 | and then not ZCX_Exceptions |
1d10f669 | 1102 | then |
06eab6a7 RD |
1103 | -- There are some special cases in which we do not do the |
1104 | -- undefer. In particular a finalization (AT END) handler | |
1105 | -- wants to operate with aborts still deferred. | |
1106 | ||
1107 | -- We also suppress the call if this is the special handler | |
1108 | -- for Abort_Signal, since if we are aborting, we want to | |
1109 | -- keep aborts deferred (one abort is enough). | |
1110 | ||
1111 | -- If abort really needs to be deferred the expander must | |
1112 | -- add this call explicitly, see | |
1113 | -- Expand_N_Asynchronous_Select. | |
1114 | ||
1115 | Others_Choice := | |
1116 | Nkind (First (Exception_Choices (Handler))) = | |
1117 | N_Others_Choice; | |
1118 | ||
1119 | if (Others_Choice | |
1120 | or else Entity (First (Exception_Choices (Handler))) /= | |
1121 | Stand.Abort_Signal) | |
1122 | and then not | |
1123 | (Others_Choice | |
1124 | and then | |
1125 | All_Others (First (Exception_Choices (Handler)))) | |
06eab6a7 RD |
1126 | then |
1127 | Prepend_Call_To_Handler (RE_Abort_Undefer); | |
1128 | end if; | |
baa3441d | 1129 | end if; |
70482933 RK |
1130 | end if; |
1131 | end if; | |
1132 | ||
baa3441d | 1133 | Handler := Next_Handler; |
fbf5a39b AC |
1134 | end loop Handler_Loop; |
1135 | ||
6c5290ce TQ |
1136 | -- If all handlers got removed, then remove the list. Note we cannot |
1137 | -- reference HSS here, since expanding local handlers may have buried | |
1138 | -- the handlers in an inner block. | |
fbf5a39b | 1139 | |
6c5290ce TQ |
1140 | if Is_Empty_List (Handlrs) then |
1141 | Set_Exception_Handlers (Parent (Handlrs), No_List); | |
fbf5a39b | 1142 | end if; |
70482933 RK |
1143 | end Expand_Exception_Handlers; |
1144 | ||
1145 | ------------------------------------ | |
1146 | -- Expand_N_Exception_Declaration -- | |
1147 | ------------------------------------ | |
1148 | ||
1149 | -- Generates: | |
1150 | -- exceptE : constant String := "A.B.EXCEP"; -- static data | |
0247964d AC |
1151 | -- except : exception_data := |
1152 | -- (Handled_By_Other => False, | |
1153 | -- Lang => 'A', | |
1154 | -- Name_Length => exceptE'Length, | |
1155 | -- Full_Name => exceptE'Address, | |
1156 | -- HTable_Ptr => null, | |
1157 | -- Foreign_Data => null, | |
1158 | -- Raise_Hook => null); | |
70482933 RK |
1159 | |
1160 | -- (protecting test only needed if not at library level) | |
0247964d | 1161 | |
70482933 RK |
1162 | -- exceptF : Boolean := True -- static data |
1163 | -- if exceptF then | |
1164 | -- exceptF := False; | |
1165 | -- Register_Exception (except'Unchecked_Access); | |
1166 | -- end if; | |
1167 | ||
1168 | procedure Expand_N_Exception_Declaration (N : Node_Id) is | |
9eb8d5b4 AC |
1169 | Id : constant Entity_Id := Defining_Identifier (N); |
1170 | Loc : constant Source_Ptr := Sloc (N); | |
70482933 | 1171 | |
3f92c93b AC |
1172 | procedure Force_Static_Allocation_Of_Referenced_Objects |
1173 | (Aggregate : Node_Id); | |
1174 | -- A specialized solution to one particular case of an ugly problem | |
1175 | -- | |
1176 | -- The given aggregate includes an Unchecked_Conversion as one of the | |
1177 | -- component values. The call to Analyze_And_Resolve below ends up | |
1178 | -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide | |
1179 | -- to introduce a (constant) temporary and then obtain the component | |
1180 | -- value by evaluating the temporary. | |
1181 | -- | |
1182 | -- In the case of an exception declared within a subprogram (or any | |
1183 | -- other dynamic scope), this is a bad transformation. The exception | |
1184 | -- object is marked as being Statically_Allocated but the temporary is | |
1185 | -- not. If the initial value of a Statically_Allocated declaration | |
1186 | -- references a dynamically allocated object, this prevents static | |
1187 | -- initialization of the object. | |
1188 | -- | |
1189 | -- We cope with this here by marking the temporary Statically_Allocated. | |
1190 | -- It might seem cleaner to generalize this utility and then use it to | |
1191 | -- enforce a rule that the entities referenced in the declaration of any | |
1192 | -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) | |
1193 | -- entity must also be either Library_Level or hoisted. It turns out | |
1194 | -- that this would be incompatible with the current treatment of an | |
1195 | -- object which is local to a subprogram, subject to an Export pragma, | |
1196 | -- not subject to an address clause, and whose declaration contains | |
1197 | -- references to other local (non-hoisted) objects (e.g., in the initial | |
1198 | -- value expression). | |
1199 | ||
9eb8d5b4 AC |
1200 | function Null_String return String_Id; |
1201 | -- Build a null-terminated empty string | |
1202 | ||
3f92c93b AC |
1203 | --------------------------------------------------- |
1204 | -- Force_Static_Allocation_Of_Referenced_Objects -- | |
1205 | --------------------------------------------------- | |
1206 | ||
1207 | procedure Force_Static_Allocation_Of_Referenced_Objects | |
1208 | (Aggregate : Node_Id) | |
1209 | is | |
1210 | function Fixup_Node (N : Node_Id) return Traverse_Result; | |
1211 | -- If the given node references a dynamically allocated object, then | |
1212 | -- correct the declaration of the object. | |
1213 | ||
1214 | ---------------- | |
1215 | -- Fixup_Node -- | |
1216 | ---------------- | |
1217 | ||
1218 | function Fixup_Node (N : Node_Id) return Traverse_Result is | |
1219 | begin | |
1220 | if Nkind (N) in N_Has_Entity | |
1221 | and then Present (Entity (N)) | |
1222 | and then not Is_Library_Level_Entity (Entity (N)) | |
1223 | ||
1224 | -- Note: the following test is not needed but it seems cleaner | |
1225 | -- to do this test (this would be more important if procedure | |
1226 | -- Force_Static_Allocation_Of_Referenced_Objects recursively | |
1227 | -- traversed the declaration of an entity after marking it as | |
1228 | -- statically allocated). | |
1229 | ||
1230 | and then not Is_Statically_Allocated (Entity (N)) | |
1231 | then | |
1232 | Set_Is_Statically_Allocated (Entity (N)); | |
1233 | end if; | |
1234 | ||
1235 | return OK; | |
1236 | end Fixup_Node; | |
1237 | ||
1238 | procedure Fixup_Tree is new Traverse_Proc (Fixup_Node); | |
1239 | ||
1240 | -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects | |
1241 | ||
1242 | begin | |
1243 | Fixup_Tree (Aggregate); | |
1244 | end Force_Static_Allocation_Of_Referenced_Objects; | |
1245 | ||
9eb8d5b4 AC |
1246 | ----------------- |
1247 | -- Null_String -- | |
1248 | ----------------- | |
1249 | ||
1250 | function Null_String return String_Id is | |
1251 | begin | |
1252 | Start_String; | |
1253 | Store_String_Char (Get_Char_Code (ASCII.NUL)); | |
1254 | return End_String; | |
1255 | end Null_String; | |
1256 | ||
1257 | -- Local variables | |
1258 | ||
1259 | Ex_Id : Entity_Id; | |
1260 | Ex_Val : String_Id; | |
1261 | Flag_Id : Entity_Id; | |
1262 | L : List_Id; | |
1263 | ||
3f92c93b AC |
1264 | -- Start of processing for Expand_N_Exception_Declaration |
1265 | ||
70482933 | 1266 | begin |
72d5c70b AC |
1267 | -- Nothing to do when generating C code |
1268 | ||
c63a2ad6 | 1269 | if Modify_Tree_For_C then |
72d5c70b AC |
1270 | return; |
1271 | end if; | |
1272 | ||
70482933 RK |
1273 | -- Definition of the external name: nam : constant String := "A.B.NAME"; |
1274 | ||
241ebe89 HK |
1275 | Ex_Id := |
1276 | Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E')); | |
1277 | ||
9eb8d5b4 AC |
1278 | -- Do not generate an external name if the exception declaration is |
1279 | -- subject to pragma Discard_Names. Use a null-terminated empty name | |
1280 | -- to ensure that Ada.Exceptions.Exception_Name functions properly. | |
1281 | ||
1282 | if Global_Discard_Names or else Discard_Names (Ex_Id) then | |
1283 | Ex_Val := Null_String; | |
1284 | ||
1285 | -- Otherwise generate the fully qualified name of the exception | |
1286 | ||
1287 | else | |
1288 | Ex_Val := Fully_Qualified_Name_String (Id); | |
1289 | end if; | |
1290 | ||
70482933 RK |
1291 | Insert_Action (N, |
1292 | Make_Object_Declaration (Loc, | |
241ebe89 | 1293 | Defining_Identifier => Ex_Id, |
70482933 RK |
1294 | Constant_Present => True, |
1295 | Object_Definition => New_Occurrence_Of (Standard_String, Loc), | |
9eb8d5b4 | 1296 | Expression => Make_String_Literal (Loc, Ex_Val))); |
70482933 | 1297 | |
241ebe89 | 1298 | Set_Is_Statically_Allocated (Ex_Id); |
70482933 RK |
1299 | |
1300 | -- Create the aggregate list for type Standard.Exception_Type: | |
1301 | -- Handled_By_Other component: False | |
1302 | ||
ad4ba28b | 1303 | L := Empty_List; |
70482933 RK |
1304 | Append_To (L, New_Occurrence_Of (Standard_False, Loc)); |
1305 | ||
1306 | -- Lang component: 'A' | |
1307 | ||
1308 | Append_To (L, | |
82c80734 | 1309 | Make_Character_Literal (Loc, |
eedc5882 HK |
1310 | Chars => Name_uA, |
1311 | Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); | |
70482933 RK |
1312 | |
1313 | -- Name_Length component: Nam'Length | |
1314 | ||
1315 | Append_To (L, | |
1316 | Make_Attribute_Reference (Loc, | |
241ebe89 | 1317 | Prefix => New_Occurrence_Of (Ex_Id, Loc), |
70482933 RK |
1318 | Attribute_Name => Name_Length)); |
1319 | ||
1320 | -- Full_Name component: Standard.A_Char!(Nam'Address) | |
1321 | ||
ec6cfc5d AC |
1322 | -- The unchecked conversion causes capacity issues for CodePeer in some |
1323 | -- cases and is never useful, so we set the Full_Name component to null | |
1324 | -- instead for CodePeer. | |
1325 | ||
1326 | if CodePeer_Mode then | |
1327 | Append_To (L, Make_Null (Loc)); | |
1328 | else | |
1329 | Append_To (L, Unchecked_Convert_To (Standard_A_Char, | |
1330 | Make_Attribute_Reference (Loc, | |
1331 | Prefix => New_Occurrence_Of (Ex_Id, Loc), | |
1332 | Attribute_Name => Name_Address))); | |
1333 | end if; | |
70482933 RK |
1334 | |
1335 | -- HTable_Ptr component: null | |
1336 | ||
1337 | Append_To (L, Make_Null (Loc)); | |
1338 | ||
e443f142 | 1339 | -- Foreign_Data component: null |
70482933 | 1340 | |
e443f142 | 1341 | Append_To (L, Make_Null (Loc)); |
70482933 | 1342 | |
fbf5a39b AC |
1343 | -- Raise_Hook component: null |
1344 | ||
1345 | Append_To (L, Make_Null (Loc)); | |
1346 | ||
70482933 RK |
1347 | Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); |
1348 | Analyze_And_Resolve (Expression (N), Etype (Id)); | |
1349 | ||
3f92c93b AC |
1350 | Force_Static_Allocation_Of_Referenced_Objects (Expression (N)); |
1351 | ||
70482933 RK |
1352 | -- Register_Exception (except'Unchecked_Access); |
1353 | ||
6c5290ce | 1354 | if not No_Exception_Handlers_Set |
6e937c1c | 1355 | and then not Restriction_Active (No_Exception_Registration) |
fbf5a39b | 1356 | then |
70482933 | 1357 | L := New_List ( |
241ebe89 HK |
1358 | Make_Procedure_Call_Statement (Loc, |
1359 | Name => | |
1360 | New_Occurrence_Of (RTE (RE_Register_Exception), Loc), | |
1361 | Parameter_Associations => New_List ( | |
1362 | Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), | |
1363 | Make_Attribute_Reference (Loc, | |
1364 | Prefix => New_Occurrence_Of (Id, Loc), | |
1365 | Attribute_Name => Name_Unrestricted_Access))))); | |
70482933 RK |
1366 | |
1367 | Set_Register_Exception_Call (Id, First (L)); | |
1368 | ||
1369 | if not Is_Library_Level_Entity (Id) then | |
241ebe89 HK |
1370 | Flag_Id := |
1371 | Make_Defining_Identifier (Loc, | |
1372 | Chars => New_External_Name (Chars (Id), 'F')); | |
70482933 RK |
1373 | |
1374 | Insert_Action (N, | |
1375 | Make_Object_Declaration (Loc, | |
1376 | Defining_Identifier => Flag_Id, | |
1377 | Object_Definition => | |
1378 | New_Occurrence_Of (Standard_Boolean, Loc), | |
1379 | Expression => | |
1380 | New_Occurrence_Of (Standard_True, Loc))); | |
1381 | ||
1382 | Set_Is_Statically_Allocated (Flag_Id); | |
1383 | ||
1384 | Append_To (L, | |
1385 | Make_Assignment_Statement (Loc, | |
1386 | Name => New_Occurrence_Of (Flag_Id, Loc), | |
1387 | Expression => New_Occurrence_Of (Standard_False, Loc))); | |
1388 | ||
1389 | Insert_After_And_Analyze (N, | |
1390 | Make_Implicit_If_Statement (N, | |
1391 | Condition => New_Occurrence_Of (Flag_Id, Loc), | |
1392 | Then_Statements => L)); | |
1393 | ||
1394 | else | |
1395 | Insert_List_After_And_Analyze (N, L); | |
1396 | end if; | |
1397 | end if; | |
70482933 RK |
1398 | end Expand_N_Exception_Declaration; |
1399 | ||
1400 | --------------------------------------------- | |
1401 | -- Expand_N_Handled_Sequence_Of_Statements -- | |
1402 | --------------------------------------------- | |
1403 | ||
1404 | procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is | |
1405 | begin | |
6c5290ce TQ |
1406 | -- Expand exception handlers |
1407 | ||
07fc65c4 | 1408 | if Present (Exception_Handlers (N)) |
6e937c1c | 1409 | and then not Restriction_Active (No_Exception_Handlers) |
07fc65c4 | 1410 | then |
70482933 RK |
1411 | Expand_Exception_Handlers (N); |
1412 | end if; | |
1413 | ||
6c5290ce TQ |
1414 | -- If local exceptions are being expanded, the previous call will |
1415 | -- have rewritten the construct as a block and reanalyzed it. No | |
1416 | -- further expansion is needed. | |
1417 | ||
1418 | if Analyzed (N) then | |
1419 | return; | |
1420 | end if; | |
1421 | ||
40c21e91 PMR |
1422 | -- Add cleanup actions if required. No cleanup actions are needed in |
1423 | -- thunks associated with interfaces, because they only displace the | |
1424 | -- pointer to the object. For extended return statements, we need | |
1425 | -- cleanup actions if the Handled_Statement_Sequence contains generated | |
1426 | -- objects of controlled types, for example. We do not want to clean up | |
1427 | -- the return object. | |
70482933 | 1428 | |
967947ed PMR |
1429 | if not Nkind_In (Parent (N), N_Accept_Statement, |
1430 | N_Extended_Return_Statement, | |
1431 | N_Package_Body) | |
70482933 | 1432 | and then not Delay_Cleanups (Current_Scope) |
da1c23dd | 1433 | and then not Is_Thunk (Current_Scope) |
70482933 RK |
1434 | then |
1435 | Expand_Cleanup_Actions (Parent (N)); | |
40c21e91 PMR |
1436 | |
1437 | elsif Nkind (Parent (N)) = N_Extended_Return_Statement | |
1438 | and then Handled_Statement_Sequence (Parent (N)) = N | |
1439 | and then not Delay_Cleanups (Current_Scope) | |
1440 | then | |
1441 | pragma Assert (not Is_Thunk (Current_Scope)); | |
1442 | Expand_Cleanup_Actions (Parent (N)); | |
1443 | ||
70482933 RK |
1444 | else |
1445 | Set_First_Real_Statement (N, First (Statements (N))); | |
1446 | end if; | |
70482933 RK |
1447 | end Expand_N_Handled_Sequence_Of_Statements; |
1448 | ||
1449 | ------------------------------------- | |
1450 | -- Expand_N_Raise_Constraint_Error -- | |
1451 | ------------------------------------- | |
1452 | ||
70482933 RK |
1453 | procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is |
1454 | begin | |
baa3441d RD |
1455 | -- We adjust the condition to deal with the C/Fortran boolean case. This |
1456 | -- may well not be necessary, as all such conditions are generated by | |
1457 | -- the expander and probably are all standard boolean, but who knows | |
a90bd866 | 1458 | -- what strange optimization in future may require this adjustment. |
baa3441d | 1459 | |
70482933 | 1460 | Adjust_Condition (Condition (N)); |
6c5290ce TQ |
1461 | |
1462 | -- Now deal with possible local raise handling | |
1463 | ||
1464 | Possible_Local_Raise (N, Standard_Constraint_Error); | |
70482933 RK |
1465 | end Expand_N_Raise_Constraint_Error; |
1466 | ||
c8d63650 RD |
1467 | ------------------------------- |
1468 | -- Expand_N_Raise_Expression -- | |
1469 | ------------------------------- | |
1470 | ||
1471 | procedure Expand_N_Raise_Expression (N : Node_Id) is | |
1472 | Loc : constant Source_Ptr := Sloc (N); | |
1473 | Typ : constant Entity_Id := Etype (N); | |
1474 | RCE : Node_Id; | |
1475 | ||
1476 | begin | |
a9895094 | 1477 | Possible_Local_Raise (N, Entity (Name (N))); |
c8d63650 RD |
1478 | |
1479 | -- Later we must teach the back end/gigi how to deal with this, but | |
1480 | -- for now we will assume the type is Standard_Boolean and transform | |
1481 | -- the node to: | |
1482 | ||
1483 | -- do | |
1484 | -- raise X [with string] | |
1485 | -- in | |
fc142f63 AC |
1486 | -- raise Constraint_Error; |
1487 | ||
1488 | -- unless the flag Convert_To_Return_False is set, in which case | |
1489 | -- the transformation is to: | |
1490 | ||
1491 | -- do | |
1492 | -- return False; | |
1493 | -- in | |
1494 | -- raise Constraint_Error; | |
c8d63650 RD |
1495 | |
1496 | -- The raise constraint error can never be executed. It is just a dummy | |
1497 | -- node that can be labeled with an arbitrary type. | |
1498 | ||
1499 | RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); | |
1500 | Set_Etype (RCE, Typ); | |
1501 | ||
fc142f63 AC |
1502 | if Convert_To_Return_False (N) then |
1503 | Rewrite (N, | |
1504 | Make_Expression_With_Actions (Loc, | |
1505 | Actions => New_List ( | |
1506 | Make_Simple_Return_Statement (Loc, | |
1507 | Expression => New_Occurrence_Of (Standard_False, Loc))), | |
1508 | Expression => RCE)); | |
1509 | ||
1510 | else | |
1511 | Rewrite (N, | |
1512 | Make_Expression_With_Actions (Loc, | |
1513 | Actions => New_List ( | |
1514 | Make_Raise_Statement (Loc, | |
1515 | Name => Name (N), | |
1516 | Expression => Expression (N))), | |
1517 | Expression => RCE)); | |
1518 | end if; | |
c8d63650 RD |
1519 | |
1520 | Analyze_And_Resolve (N, Typ); | |
1521 | end Expand_N_Raise_Expression; | |
1522 | ||
70482933 RK |
1523 | ---------------------------------- |
1524 | -- Expand_N_Raise_Program_Error -- | |
1525 | ---------------------------------- | |
1526 | ||
70482933 RK |
1527 | procedure Expand_N_Raise_Program_Error (N : Node_Id) is |
1528 | begin | |
baa3441d RD |
1529 | -- We adjust the condition to deal with the C/Fortran boolean case. This |
1530 | -- may well not be necessary, as all such conditions are generated by | |
1531 | -- the expander and probably are all standard boolean, but who knows | |
a90bd866 | 1532 | -- what strange optimization in future may require this adjustment. |
baa3441d | 1533 | |
70482933 | 1534 | Adjust_Condition (Condition (N)); |
6c5290ce TQ |
1535 | |
1536 | -- Now deal with possible local raise handling | |
1537 | ||
1538 | Possible_Local_Raise (N, Standard_Program_Error); | |
70482933 RK |
1539 | end Expand_N_Raise_Program_Error; |
1540 | ||
1541 | ------------------------------ | |
1542 | -- Expand_N_Raise_Statement -- | |
1543 | ------------------------------ | |
1544 | ||
1545 | procedure Expand_N_Raise_Statement (N : Node_Id) is | |
1546 | Loc : constant Source_Ptr := Sloc (N); | |
1547 | Ehand : Node_Id; | |
1548 | E : Entity_Id; | |
1549 | Str : String_Id; | |
baa3441d | 1550 | H : Node_Id; |
84df40f7 | 1551 | Src : Boolean; |
70482933 RK |
1552 | |
1553 | begin | |
baa3441d RD |
1554 | -- Processing for locally handled exception (exclude reraise case) |
1555 | ||
1556 | if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then | |
1557 | if Debug_Flag_Dot_G | |
1558 | or else Restriction_Active (No_Exception_Propagation) | |
1559 | then | |
1560 | -- If we have a local handler, then note that this is potentially | |
1561 | -- able to be transformed into a goto statement. | |
1562 | ||
1563 | H := Find_Local_Handler (Entity (Name (N)), N); | |
1564 | ||
1565 | if Present (H) then | |
1566 | if Local_Raise_Statements (H) = No_Elist then | |
1567 | Set_Local_Raise_Statements (H, New_Elmt_List); | |
1568 | end if; | |
1569 | ||
1570 | -- Append the new entry if it is not there already. Sometimes | |
1571 | -- we have situations where due to reexpansion, the same node | |
1572 | -- is analyzed twice and would otherwise be added twice. | |
1573 | ||
1574 | Append_Unique_Elmt (N, Local_Raise_Statements (H)); | |
6c5290ce TQ |
1575 | Set_Has_Local_Raise (H); |
1576 | ||
1577 | -- If no local handler, then generate no propagation warning | |
1578 | ||
1579 | else | |
1580 | Warn_If_No_Propagation (N); | |
baa3441d RD |
1581 | end if; |
1582 | ||
baa3441d RD |
1583 | end if; |
1584 | end if; | |
1585 | ||
a9d8907c JM |
1586 | -- If a string expression is present, then the raise statement is |
1587 | -- converted to a call: | |
a9d8907c | 1588 | -- Raise_Exception (exception-name'Identity, string); |
49f7fe60 | 1589 | -- and there is nothing else to do. |
a9d8907c JM |
1590 | |
1591 | if Present (Expression (N)) then | |
7340e432 | 1592 | |
8f819471 RD |
1593 | -- Adjust message to deal with Prefix_Exception_Messages. We only |
1594 | -- add the prefix to string literals, if the message is being | |
1595 | -- constructed, we assume it already deals with uniqueness. | |
1596 | ||
1597 | if Prefix_Exception_Messages | |
1598 | and then Nkind (Expression (N)) = N_String_Literal | |
1599 | then | |
b269f477 BD |
1600 | declare |
1601 | Buf : Bounded_String; | |
1602 | begin | |
1603 | Add_Source_Info (Buf, Loc, Name_Enclosing_Entity); | |
1604 | Append (Buf, ": "); | |
1605 | Append (Buf, Strval (Expression (N))); | |
1606 | Rewrite (Expression (N), Make_String_Literal (Loc, +Buf)); | |
1607 | Analyze_And_Resolve (Expression (N), Standard_String); | |
1608 | end; | |
8f819471 RD |
1609 | end if; |
1610 | ||
7340e432 AC |
1611 | -- Avoid passing exception-name'identity in runtimes in which this |
1612 | -- argument is not used. This avoids generating undefined references | |
1613 | -- to these exceptions when compiling with no optimization | |
1614 | ||
1615 | if Configurable_Run_Time_On_Target | |
1616 | and then (Restriction_Active (No_Exception_Handlers) | |
1617 | or else | |
1618 | Restriction_Active (No_Exception_Propagation)) | |
1619 | then | |
1620 | Rewrite (N, | |
1621 | Make_Procedure_Call_Statement (Loc, | |
1622 | Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), | |
1623 | Parameter_Associations => New_List ( | |
1624 | New_Occurrence_Of (RTE (RE_Null_Id), Loc), | |
1625 | Expression (N)))); | |
1626 | else | |
1627 | Rewrite (N, | |
1628 | Make_Procedure_Call_Statement (Loc, | |
1629 | Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), | |
1630 | Parameter_Associations => New_List ( | |
1631 | Make_Attribute_Reference (Loc, | |
1632 | Prefix => Name (N), | |
1633 | Attribute_Name => Name_Identity), | |
1634 | Expression (N)))); | |
1635 | end if; | |
1636 | ||
a9d8907c JM |
1637 | Analyze (N); |
1638 | return; | |
1639 | end if; | |
1640 | ||
84df40f7 AC |
1641 | -- Remaining processing is for the case where no string expression is |
1642 | -- present. | |
a9d8907c | 1643 | |
84df40f7 AC |
1644 | -- Don't expand a raise statement that does not come from source if we |
1645 | -- have already had configurable run-time violations, since most likely | |
1646 | -- it will be junk cascaded nonsense. | |
fbf5a39b AC |
1647 | |
1648 | if Configurable_Run_Time_Violations > 0 | |
1649 | and then not Comes_From_Source (N) | |
1650 | then | |
1651 | return; | |
1652 | end if; | |
1653 | ||
70482933 | 1654 | -- Convert explicit raise of Program_Error, Constraint_Error, and |
fbf5a39b AC |
1655 | -- Storage_Error into the corresponding raise (in High_Integrity_Mode |
1656 | -- all other raises will get normal expansion and be disallowed, | |
84df40f7 AC |
1657 | -- but this is also faster in all modes). Propagate Comes_From_Source |
1658 | -- flag to the new node. | |
70482933 RK |
1659 | |
1660 | if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then | |
84df40f7 | 1661 | Src := Comes_From_Source (N); |
61c161b2 | 1662 | |
07fc65c4 GB |
1663 | if Entity (Name (N)) = Standard_Constraint_Error then |
1664 | Rewrite (N, | |
84df40f7 AC |
1665 | Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise)); |
1666 | Set_Comes_From_Source (N, Src); | |
70482933 RK |
1667 | Analyze (N); |
1668 | return; | |
1669 | ||
07fc65c4 GB |
1670 | elsif Entity (Name (N)) = Standard_Program_Error then |
1671 | Rewrite (N, | |
84df40f7 AC |
1672 | Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); |
1673 | Set_Comes_From_Source (N, Src); | |
70482933 RK |
1674 | Analyze (N); |
1675 | return; | |
1676 | ||
1677 | elsif Entity (Name (N)) = Standard_Storage_Error then | |
07fc65c4 | 1678 | Rewrite (N, |
84df40f7 AC |
1679 | Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise)); |
1680 | Set_Comes_From_Source (N, Src); | |
70482933 RK |
1681 | Analyze (N); |
1682 | return; | |
1683 | end if; | |
1684 | end if; | |
1685 | ||
1686 | -- Case of name present, in this case we expand raise name to | |
1687 | ||
1688 | -- Raise_Exception (name'Identity, location_string); | |
1689 | ||
1690 | -- where location_string identifies the file/line of the raise | |
1691 | ||
1692 | if Present (Name (N)) then | |
1693 | declare | |
1694 | Id : Entity_Id := Entity (Name (N)); | |
ea102799 | 1695 | Buf : Bounded_String; |
70482933 RK |
1696 | |
1697 | begin | |
ea102799 | 1698 | Build_Location_String (Buf, Loc); |
70482933 | 1699 | |
07fc65c4 GB |
1700 | -- If the exception is a renaming, use the exception that it |
1701 | -- renames (which might be a predefined exception, e.g.). | |
1702 | ||
1703 | if Present (Renamed_Object (Id)) then | |
1704 | Id := Renamed_Object (Id); | |
1705 | end if; | |
1706 | ||
fbf5a39b | 1707 | -- Build a C-compatible string in case of no exception handlers, |
70482933 RK |
1708 | -- since this is what the last chance handler is expecting. |
1709 | ||
6c5290ce | 1710 | if No_Exception_Handlers_Set then |
70482933 | 1711 | |
fbf5a39b AC |
1712 | -- Generate an empty message if configuration pragma |
1713 | -- Suppress_Exception_Locations is set for this unit. | |
1714 | ||
1715 | if Opt.Exception_Locations_Suppressed then | |
ea102799 | 1716 | Buf.Length := 0; |
70482933 RK |
1717 | end if; |
1718 | ||
ea102799 | 1719 | Append (Buf, ASCII.NUL); |
fbf5a39b AC |
1720 | end if; |
1721 | ||
fbf5a39b | 1722 | if Opt.Exception_Locations_Suppressed then |
ea102799 | 1723 | Buf.Length := 0; |
70482933 RK |
1724 | end if; |
1725 | ||
ea102799 | 1726 | Str := String_From_Name_Buffer (Buf); |
70482933 | 1727 | |
ea0c8cfb | 1728 | -- Convert raise to call to the Raise_Exception routine |
70482933 | 1729 | |
ea0c8cfb RD |
1730 | Rewrite (N, |
1731 | Make_Procedure_Call_Statement (Loc, | |
1732 | Name => | |
1733 | New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), | |
1734 | Parameter_Associations => New_List ( | |
1735 | Make_Attribute_Reference (Loc, | |
1736 | Prefix => Name (N), | |
1737 | Attribute_Name => Name_Identity), | |
1738 | Make_String_Literal (Loc, Strval => Str)))); | |
70482933 RK |
1739 | end; |
1740 | ||
1741 | -- Case of no name present (reraise). We rewrite the raise to: | |
1742 | ||
1743 | -- Reraise_Occurrence_Always (EO); | |
1744 | ||
1745 | -- where EO is the current exception occurrence. If the current handler | |
1746 | -- does not have a choice parameter specification, then we provide one. | |
1747 | ||
1748 | else | |
60370fb1 | 1749 | -- Bypass expansion to a run-time call when back-end exception |
535a8637 AC |
1750 | -- handling is active, unless the target is CodePeer or GNATprove. |
1751 | -- In CodePeer, raising an exception is treated as an error, while in | |
1752 | -- GNATprove all code with exceptions falls outside the subset of | |
1753 | -- code which can be formally analyzed. | |
5accd7b6 | 1754 | |
535a8637 | 1755 | if not CodePeer_Mode |
0ab0bf95 | 1756 | and then Back_End_Exceptions |
5accd7b6 AC |
1757 | then |
1758 | return; | |
1759 | end if; | |
1760 | ||
70482933 RK |
1761 | -- Find innermost enclosing exception handler (there must be one, |
1762 | -- since the semantics has already verified that this raise statement | |
1763 | -- is valid, and a raise with no arguments is only permitted in the | |
1764 | -- context of an exception handler. | |
1765 | ||
1766 | Ehand := Parent (N); | |
1767 | while Nkind (Ehand) /= N_Exception_Handler loop | |
1768 | Ehand := Parent (Ehand); | |
1769 | end loop; | |
1770 | ||
1771 | -- Make exception choice parameter if none present. Note that we do | |
1772 | -- not need to put the entity on the entity chain, since no one will | |
1773 | -- be referencing this entity by normal visibility methods. | |
1774 | ||
1775 | if No (Choice_Parameter (Ehand)) then | |
191fcb3a | 1776 | E := Make_Temporary (Loc, 'E'); |
70482933 RK |
1777 | Set_Choice_Parameter (Ehand, E); |
1778 | Set_Ekind (E, E_Variable); | |
1779 | Set_Etype (E, RTE (RE_Exception_Occurrence)); | |
1780 | Set_Scope (E, Current_Scope); | |
1781 | end if; | |
1782 | ||
1783 | -- Now rewrite the raise as a call to Reraise. A special case arises | |
1784 | -- if this raise statement occurs in the context of a handler for | |
1785 | -- all others (i.e. an at end handler). in this case we avoid | |
1786 | -- the call to defer abort, cleanup routines are expected to be | |
1787 | -- called in this case with aborts deferred. | |
1788 | ||
1789 | declare | |
1790 | Ech : constant Node_Id := First (Exception_Choices (Ehand)); | |
1791 | Ent : Entity_Id; | |
1792 | ||
1793 | begin | |
1794 | if Nkind (Ech) = N_Others_Choice | |
1795 | and then All_Others (Ech) | |
1796 | then | |
1797 | Ent := RTE (RE_Reraise_Occurrence_No_Defer); | |
1798 | else | |
1799 | Ent := RTE (RE_Reraise_Occurrence_Always); | |
1800 | end if; | |
1801 | ||
1802 | Rewrite (N, | |
1803 | Make_Procedure_Call_Statement (Loc, | |
1804 | Name => New_Occurrence_Of (Ent, Loc), | |
1805 | Parameter_Associations => New_List ( | |
1806 | New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); | |
1807 | end; | |
1808 | end if; | |
1809 | ||
1810 | Analyze (N); | |
1811 | end Expand_N_Raise_Statement; | |
1812 | ||
1813 | ---------------------------------- | |
1814 | -- Expand_N_Raise_Storage_Error -- | |
1815 | ---------------------------------- | |
1816 | ||
70482933 RK |
1817 | procedure Expand_N_Raise_Storage_Error (N : Node_Id) is |
1818 | begin | |
baa3441d RD |
1819 | -- We adjust the condition to deal with the C/Fortran boolean case. This |
1820 | -- may well not be necessary, as all such conditions are generated by | |
1821 | -- the expander and probably are all standard boolean, but who knows | |
a90bd866 | 1822 | -- what strange optimization in future may require this adjustment. |
baa3441d | 1823 | |
70482933 | 1824 | Adjust_Condition (Condition (N)); |
6c5290ce TQ |
1825 | |
1826 | -- Now deal with possible local raise handling | |
1827 | ||
1828 | Possible_Local_Raise (N, Standard_Storage_Error); | |
70482933 RK |
1829 | end Expand_N_Raise_Storage_Error; |
1830 | ||
6c5290ce TQ |
1831 | -------------------------- |
1832 | -- Possible_Local_Raise -- | |
1833 | -------------------------- | |
1834 | ||
1835 | procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is | |
1836 | begin | |
1837 | -- Nothing to do if local raise optimization not active | |
1838 | ||
1839 | if not Debug_Flag_Dot_G | |
1840 | and then not Restriction_Active (No_Exception_Propagation) | |
1841 | then | |
1842 | return; | |
1843 | end if; | |
1844 | ||
1845 | -- Nothing to do if original node was an explicit raise, because in | |
1846 | -- that case, we already generated the required warning for the raise. | |
1847 | ||
1848 | if Nkind (Original_Node (N)) = N_Raise_Statement then | |
1849 | return; | |
1850 | end if; | |
1851 | ||
1852 | -- Otherwise see if we have a local handler for the exception | |
1853 | ||
1854 | declare | |
1855 | H : constant Node_Id := Find_Local_Handler (E, N); | |
1856 | ||
1857 | begin | |
1858 | -- If so, mark that it has a local raise | |
1859 | ||
1860 | if Present (H) then | |
1861 | Set_Has_Local_Raise (H, True); | |
1862 | ||
1863 | -- Otherwise, if the No_Exception_Propagation restriction is active | |
1864 | -- and the warning is enabled, generate the appropriate warnings. | |
1865 | ||
8f8f531f | 1866 | -- ??? Do not do it for the Call_Marker nodes inserted by the ABE |
dcd5fd67 PMR |
1867 | -- mechanism because this generates too many false positives, or |
1868 | -- for generic instantiations for the same reason. | |
8f8f531f | 1869 | |
6c5290ce TQ |
1870 | elsif Warn_On_Non_Local_Exception |
1871 | and then Restriction_Active (No_Exception_Propagation) | |
8f8f531f | 1872 | and then Nkind (N) /= N_Call_Marker |
dcd5fd67 | 1873 | and then Nkind (N) not in N_Generic_Instantiation |
6c5290ce TQ |
1874 | then |
1875 | Warn_No_Exception_Propagation_Active (N); | |
1876 | ||
1877 | if Configurable_Run_Time_Mode then | |
1878 | Error_Msg_NE | |
324ac540 | 1879 | ("\?X?& may call Last_Chance_Handler", N, E); |
6c5290ce TQ |
1880 | else |
1881 | Error_Msg_NE | |
324ac540 | 1882 | ("\?X?& may result in unhandled exception", N, E); |
6c5290ce TQ |
1883 | end if; |
1884 | end if; | |
1885 | end; | |
1886 | end Possible_Local_Raise; | |
1887 | ||
baa3441d RD |
1888 | ------------------------ |
1889 | -- Find_Local_Handler -- | |
1890 | ------------------------ | |
1891 | ||
1892 | function Find_Local_Handler | |
1893 | (Ename : Entity_Id; | |
1894 | Nod : Node_Id) return Node_Id | |
1895 | is | |
1896 | N : Node_Id; | |
1897 | P : Node_Id; | |
1898 | H : Node_Id; | |
1899 | C : Node_Id; | |
1900 | ||
6c5290ce TQ |
1901 | SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); |
1902 | -- This is used to test for wrapped actions below | |
1903 | ||
baa3441d RD |
1904 | ERaise : Entity_Id; |
1905 | EHandle : Entity_Id; | |
1906 | -- The entity Id's for the exception we are raising and handling, using | |
1907 | -- the renamed exception if a Renamed_Entity is present. | |
1908 | ||
1909 | begin | |
6c5290ce TQ |
1910 | -- Never any local handler if all handlers removed |
1911 | ||
1912 | if Debug_Flag_Dot_X then | |
1913 | return Empty; | |
1914 | end if; | |
1915 | ||
baa3441d RD |
1916 | -- Get the exception we are raising, allowing for renaming |
1917 | ||
6c5290ce TQ |
1918 | ERaise := Get_Renamed_Entity (Ename); |
1919 | ||
1920 | -- We need to check if the node we are looking at is contained in | |
1921 | -- | |
baa3441d RD |
1922 | |
1923 | -- Loop to search up the tree | |
1924 | ||
1925 | N := Nod; | |
1926 | loop | |
1927 | P := Parent (N); | |
1928 | ||
1929 | -- If we get to the top of the tree, or to a subprogram, task, entry, | |
6c5290ce TQ |
1930 | -- protected body, or accept statement without having found a |
1931 | -- matching handler, then there is no local handler. | |
baa3441d RD |
1932 | |
1933 | if No (P) | |
1934 | or else Nkind (P) = N_Subprogram_Body | |
1935 | or else Nkind (P) = N_Task_Body | |
1936 | or else Nkind (P) = N_Protected_Body | |
1937 | or else Nkind (P) = N_Entry_Body | |
6c5290ce | 1938 | or else Nkind (P) = N_Accept_Statement |
baa3441d RD |
1939 | then |
1940 | return Empty; | |
1941 | ||
6c5290ce TQ |
1942 | -- Test for handled sequence of statements with at least one |
1943 | -- exception handler which might be the one we are looking for. | |
baa3441d RD |
1944 | |
1945 | elsif Nkind (P) = N_Handled_Sequence_Of_Statements | |
6c5290ce | 1946 | and then Present (Exception_Handlers (P)) |
baa3441d | 1947 | then |
6c5290ce TQ |
1948 | -- Before we proceed we need to check if the node N is covered |
1949 | -- by the statement part of P rather than one of its exception | |
1950 | -- handlers (an exception handler obviously does not cover its | |
1951 | -- own statements). | |
1952 | ||
1953 | -- This test is more delicate than might be thought. It is not | |
1954 | -- just a matter of checking the Statements (P), because the node | |
1955 | -- might be waiting to be wrapped in a transient scope, in which | |
1956 | -- case it will end up in the block statements, even though it | |
1957 | -- is not there now. | |
1958 | ||
799d0e05 AC |
1959 | if Is_List_Member (N) then |
1960 | declare | |
1961 | LCN : constant List_Id := List_Containing (N); | |
baa3441d | 1962 | |
799d0e05 AC |
1963 | begin |
1964 | if LCN = Statements (P) | |
1965 | or else | |
36295779 | 1966 | LCN = SSE.Actions_To_Be_Wrapped (Before) |
799d0e05 | 1967 | or else |
36295779 AC |
1968 | LCN = SSE.Actions_To_Be_Wrapped (After) |
1969 | or else | |
1970 | LCN = SSE.Actions_To_Be_Wrapped (Cleanup) | |
799d0e05 AC |
1971 | then |
1972 | -- Loop through exception handlers | |
baa3441d | 1973 | |
799d0e05 AC |
1974 | H := First (Exception_Handlers (P)); |
1975 | while Present (H) loop | |
baa3441d | 1976 | |
799d0e05 AC |
1977 | -- Guard against other constructs appearing in the |
1978 | -- list of exception handlers. | |
baa3441d | 1979 | |
799d0e05 | 1980 | if Nkind (H) = N_Exception_Handler then |
baa3441d | 1981 | |
799d0e05 | 1982 | -- Loop through choices in one handler |
baa3441d | 1983 | |
799d0e05 AC |
1984 | C := First (Exception_Choices (H)); |
1985 | while Present (C) loop | |
baa3441d | 1986 | |
799d0e05 | 1987 | -- Deal with others case |
baa3441d | 1988 | |
799d0e05 | 1989 | if Nkind (C) = N_Others_Choice then |
baa3441d | 1990 | |
799d0e05 AC |
1991 | -- Matching others handler, but we need |
1992 | -- to ensure there is no choice parameter. | |
1993 | -- If there is, then we don't have a local | |
1994 | -- handler after all (since we do not allow | |
1995 | -- choice parameters for local handlers). | |
2f7b7467 | 1996 | |
799d0e05 AC |
1997 | if No (Choice_Parameter (H)) then |
1998 | return H; | |
1999 | else | |
2000 | return Empty; | |
2001 | end if; | |
2f7b7467 | 2002 | |
799d0e05 | 2003 | -- If not others must be entity name |
2f7b7467 | 2004 | |
799d0e05 AC |
2005 | elsif Nkind (C) /= N_Others_Choice then |
2006 | pragma Assert (Is_Entity_Name (C)); | |
2007 | pragma Assert (Present (Entity (C))); | |
2f7b7467 | 2008 | |
799d0e05 AC |
2009 | -- Get exception being handled, dealing with |
2010 | -- renaming. | |
2f7b7467 | 2011 | |
799d0e05 | 2012 | EHandle := Get_Renamed_Entity (Entity (C)); |
2f7b7467 | 2013 | |
799d0e05 AC |
2014 | -- If match, then check choice parameter |
2015 | ||
2016 | if ERaise = EHandle then | |
2017 | if No (Choice_Parameter (H)) then | |
2018 | return H; | |
2019 | else | |
2020 | return Empty; | |
2021 | end if; | |
2022 | end if; | |
2f7b7467 | 2023 | end if; |
799d0e05 AC |
2024 | |
2025 | Next (C); | |
2026 | end loop; | |
baa3441d | 2027 | end if; |
baa3441d | 2028 | |
799d0e05 | 2029 | Next (H); |
2f7b7467 AC |
2030 | end loop; |
2031 | end if; | |
799d0e05 | 2032 | end; |
baa3441d RD |
2033 | end if; |
2034 | end if; | |
2035 | ||
2036 | N := P; | |
2037 | end loop; | |
2038 | end Find_Local_Handler; | |
2039 | ||
2040 | --------------------------------- | |
2041 | -- Get_Local_Raise_Call_Entity -- | |
2042 | --------------------------------- | |
2043 | ||
d1915cb8 | 2044 | -- Note: this is primarily provided for use by the back end in generating |
6c5290ce TQ |
2045 | -- calls to Local_Raise. But it would be too late in the back end to call |
2046 | -- RTE if this actually caused a load/analyze of the unit. So what we do | |
2047 | -- is to ensure there is a dummy call to this function during front end | |
2048 | -- processing so that the unit gets loaded then, and not later. | |
2049 | ||
2050 | Local_Raise_Call_Entity : Entity_Id; | |
2051 | Local_Raise_Call_Entity_Set : Boolean := False; | |
2052 | ||
baa3441d RD |
2053 | function Get_Local_Raise_Call_Entity return Entity_Id is |
2054 | begin | |
6c5290ce TQ |
2055 | if not Local_Raise_Call_Entity_Set then |
2056 | Local_Raise_Call_Entity_Set := True; | |
2057 | ||
2058 | if RTE_Available (RE_Local_Raise) then | |
2059 | Local_Raise_Call_Entity := RTE (RE_Local_Raise); | |
2060 | else | |
2061 | Local_Raise_Call_Entity := Empty; | |
2062 | end if; | |
baa3441d | 2063 | end if; |
6c5290ce TQ |
2064 | |
2065 | return Local_Raise_Call_Entity; | |
baa3441d RD |
2066 | end Get_Local_Raise_Call_Entity; |
2067 | ||
2068 | ----------------------------- | |
2069 | -- Get_RT_Exception_Entity -- | |
2070 | ----------------------------- | |
2071 | ||
2072 | function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is | |
2073 | begin | |
a2cc9797 | 2074 | case Rkind (R) is |
effdbb7d AC |
2075 | when CE_Reason => return Standard_Constraint_Error; |
2076 | when PE_Reason => return Standard_Program_Error; | |
2077 | when SE_Reason => return Standard_Storage_Error; | |
baa3441d RD |
2078 | end case; |
2079 | end Get_RT_Exception_Entity; | |
2080 | ||
0c644c99 TG |
2081 | --------------------------- |
2082 | -- Get_RT_Exception_Name -- | |
2083 | --------------------------- | |
2084 | ||
2085 | procedure Get_RT_Exception_Name (Code : RT_Exception_Code) is | |
2086 | begin | |
2087 | case Code is | |
2088 | when CE_Access_Check_Failed => | |
2089 | Add_Str_To_Name_Buffer ("CE_Access_Check"); | |
2090 | when CE_Access_Parameter_Is_Null => | |
2091 | Add_Str_To_Name_Buffer ("CE_Null_Access_Parameter"); | |
2092 | when CE_Discriminant_Check_Failed => | |
2093 | Add_Str_To_Name_Buffer ("CE_Discriminant_Check"); | |
2094 | when CE_Divide_By_Zero => | |
2095 | Add_Str_To_Name_Buffer ("CE_Divide_By_Zero"); | |
2096 | when CE_Explicit_Raise => | |
2097 | Add_Str_To_Name_Buffer ("CE_Explicit_Raise"); | |
2098 | when CE_Index_Check_Failed => | |
2099 | Add_Str_To_Name_Buffer ("CE_Index_Check"); | |
2100 | when CE_Invalid_Data => | |
2101 | Add_Str_To_Name_Buffer ("CE_Invalid_Data"); | |
2102 | when CE_Length_Check_Failed => | |
2103 | Add_Str_To_Name_Buffer ("CE_Length_Check"); | |
2104 | when CE_Null_Exception_Id => | |
2105 | Add_Str_To_Name_Buffer ("CE_Null_Exception_Id"); | |
2106 | when CE_Null_Not_Allowed => | |
2107 | Add_Str_To_Name_Buffer ("CE_Null_Not_Allowed"); | |
2108 | when CE_Overflow_Check_Failed => | |
2109 | Add_Str_To_Name_Buffer ("CE_Overflow_Check"); | |
2110 | when CE_Partition_Check_Failed => | |
2111 | Add_Str_To_Name_Buffer ("CE_Partition_Check"); | |
2112 | when CE_Range_Check_Failed => | |
2113 | Add_Str_To_Name_Buffer ("CE_Range_Check"); | |
2114 | when CE_Tag_Check_Failed => | |
2115 | Add_Str_To_Name_Buffer ("CE_Tag_Check"); | |
2116 | ||
2117 | when PE_Access_Before_Elaboration => | |
2118 | Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration"); | |
2119 | when PE_Accessibility_Check_Failed => | |
2120 | Add_Str_To_Name_Buffer ("PE_Accessibility_Check"); | |
2121 | when PE_Address_Of_Intrinsic => | |
2122 | Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic"); | |
baed70ac AC |
2123 | when PE_Aliased_Parameters => |
2124 | Add_Str_To_Name_Buffer ("PE_Aliased_Parameters"); | |
0c644c99 TG |
2125 | when PE_All_Guards_Closed => |
2126 | Add_Str_To_Name_Buffer ("PE_All_Guards_Closed"); | |
2127 | when PE_Bad_Predicated_Generic_Type => | |
2128 | Add_Str_To_Name_Buffer ("PE_Bad_Predicated_Generic_Type"); | |
fc47ef60 PMR |
2129 | when PE_Build_In_Place_Mismatch => |
2130 | Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch"); | |
0c644c99 TG |
2131 | when PE_Current_Task_In_Entry_Body => |
2132 | Add_Str_To_Name_Buffer ("PE_Current_Task_In_Entry_Body"); | |
2133 | when PE_Duplicated_Entry_Address => | |
2134 | Add_Str_To_Name_Buffer ("PE_Duplicated_Entry_Address"); | |
2135 | when PE_Explicit_Raise => | |
2136 | Add_Str_To_Name_Buffer ("PE_Explicit_Raise"); | |
2137 | when PE_Finalize_Raised_Exception => | |
2138 | Add_Str_To_Name_Buffer ("PE_Finalize_Raised_Exception"); | |
2139 | when PE_Implicit_Return => | |
2140 | Add_Str_To_Name_Buffer ("PE_Implicit_Return"); | |
2141 | when PE_Misaligned_Address_Value => | |
2142 | Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value"); | |
2143 | when PE_Missing_Return => | |
2144 | Add_Str_To_Name_Buffer ("PE_Missing_Return"); | |
b8b2d982 AC |
2145 | when PE_Non_Transportable_Actual => |
2146 | Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); | |
0c644c99 TG |
2147 | when PE_Overlaid_Controlled_Object => |
2148 | Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object"); | |
2149 | when PE_Potentially_Blocking_Operation => | |
2150 | Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation"); | |
b8b2d982 AC |
2151 | when PE_Stream_Operation_Not_Allowed => |
2152 | Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed"); | |
0c644c99 TG |
2153 | when PE_Stubbed_Subprogram_Called => |
2154 | Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called"); | |
2155 | when PE_Unchecked_Union_Restriction => | |
2156 | Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction"); | |
0c644c99 TG |
2157 | |
2158 | when SE_Empty_Storage_Pool => | |
2159 | Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool"); | |
2160 | when SE_Explicit_Raise => | |
2161 | Add_Str_To_Name_Buffer ("SE_Explicit_Raise"); | |
2162 | when SE_Infinite_Recursion => | |
2163 | Add_Str_To_Name_Buffer ("SE_Infinite_Recursion"); | |
2164 | when SE_Object_Too_Large => | |
2165 | Add_Str_To_Name_Buffer ("SE_Object_Too_Large"); | |
2166 | end case; | |
2167 | end Get_RT_Exception_Name; | |
2168 | ||
8f8f531f PMR |
2169 | ---------------------------- |
2170 | -- Warn_If_No_Local_Raise -- | |
2171 | ---------------------------- | |
2172 | ||
2173 | procedure Warn_If_No_Local_Raise (N : Node_Id) is | |
2174 | begin | |
2175 | if Restriction_Active (No_Exception_Propagation) | |
2176 | and then Warn_On_Non_Local_Exception | |
2177 | then | |
2178 | Warn_No_Exception_Propagation_Active (N); | |
2179 | ||
2180 | Error_Msg_N | |
2181 | ("\?X?this handler can never be entered, and has been removed", N); | |
2182 | end if; | |
2183 | end Warn_If_No_Local_Raise; | |
2184 | ||
baa3441d RD |
2185 | ---------------------------- |
2186 | -- Warn_If_No_Propagation -- | |
2187 | ---------------------------- | |
2188 | ||
2189 | procedure Warn_If_No_Propagation (N : Node_Id) is | |
2190 | begin | |
7a963087 | 2191 | if Restriction_Check_Required (No_Exception_Propagation) |
baa3441d RD |
2192 | and then Warn_On_Non_Local_Exception |
2193 | then | |
6c5290ce | 2194 | Warn_No_Exception_Propagation_Active (N); |
baa3441d RD |
2195 | |
2196 | if Configurable_Run_Time_Mode then | |
2197 | Error_Msg_N | |
324ac540 | 2198 | ("\?X?Last_Chance_Handler will be called on exception", N); |
baa3441d RD |
2199 | else |
2200 | Error_Msg_N | |
324ac540 | 2201 | ("\?X?execution may raise unhandled exception", N); |
baa3441d RD |
2202 | end if; |
2203 | end if; | |
2204 | end Warn_If_No_Propagation; | |
2205 | ||
6c5290ce TQ |
2206 | ------------------------------------------ |
2207 | -- Warn_No_Exception_Propagation_Active -- | |
2208 | ------------------------------------------ | |
2209 | ||
2210 | procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is | |
2211 | begin | |
2212 | Error_Msg_N | |
324ac540 | 2213 | ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N); |
6c5290ce TQ |
2214 | end Warn_No_Exception_Propagation_Active; |
2215 | ||
70482933 | 2216 | end Exp_Ch11; |