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