|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ C H 1 1 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Debug; use Debug;
|
|
|
28 with Einfo; use Einfo;
|
|
|
29 with Elists; use Elists;
|
|
|
30 with Errout; use Errout;
|
|
|
31 with Exp_Ch7; use Exp_Ch7;
|
|
|
32 with Exp_Intr; use Exp_Intr;
|
|
|
33 with Exp_Util; use Exp_Util;
|
|
|
34 with Namet; use Namet;
|
|
|
35 with Nlists; use Nlists;
|
|
|
36 with Nmake; use Nmake;
|
|
|
37 with Opt; use Opt;
|
|
|
38 with Restrict; use Restrict;
|
|
|
39 with Rident; use Rident;
|
|
|
40 with Rtsfind; use Rtsfind;
|
|
|
41 with Sem; use Sem;
|
|
|
42 with Sem_Ch8; use Sem_Ch8;
|
|
|
43 with Sem_Res; use Sem_Res;
|
|
|
44 with Sem_Util; use Sem_Util;
|
|
|
45 with Sinfo; use Sinfo;
|
|
|
46 with Sinput; use Sinput;
|
|
|
47 with Snames; use Snames;
|
|
|
48 with Stand; use Stand;
|
|
|
49 with Stringt; use Stringt;
|
|
|
50 with Targparm; use Targparm;
|
|
|
51 with Tbuild; use Tbuild;
|
|
|
52 with Uintp; use Uintp;
|
|
|
53
|
|
|
54 package body Exp_Ch11 is
|
|
|
55
|
|
|
56 -----------------------
|
|
|
57 -- Local Subprograms --
|
|
|
58 -----------------------
|
|
|
59
|
|
|
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.
|
|
|
64
|
|
|
65 procedure Warn_If_No_Propagation (N : Node_Id);
|
|
145
|
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
|
|
111
|
68 -- restriction is set. N is the node for the raise or equivalent call.
|
|
|
69
|
|
|
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
|
|
|
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
|
|
|
102 procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is
|
|
|
103 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
|
|
|
104 Ohandle : Node_Id;
|
|
|
105 Stmnts : List_Id;
|
|
|
106
|
|
|
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
|
|
|
115 begin
|
|
|
116 pragma Assert (Present (Clean));
|
|
|
117 pragma Assert (No (Exception_Handlers (HSS)));
|
|
|
118
|
|
|
119 -- Back end exception schemes don't need explicit handlers to
|
|
|
120 -- trigger AT-END actions on exceptional paths.
|
|
|
121
|
|
|
122 if Back_End_Exceptions then
|
|
|
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
|
|
|
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
|
|
|
139 return;
|
|
|
140 end if;
|
|
|
141
|
|
|
142 if Present (Blk_Id) then
|
|
|
143 Push_Scope (Blk_Id);
|
|
|
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,
|
|
|
152 Name => New_Occurrence_Of (Clean, Loc)));
|
|
|
153
|
|
|
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.
|
|
|
161
|
|
|
162 if not Restriction_Active (No_Exception_Propagation) then
|
|
|
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;
|
|
|
169 end if;
|
|
|
170
|
|
|
171 Set_Exception_Handlers (HSS, New_List (
|
|
|
172 Make_Implicit_Exception_Handler (Loc,
|
|
|
173 Exception_Choices => New_List (Ohandle),
|
|
|
174 Statements => Stmnts)));
|
|
|
175
|
|
|
176 Analyze_List (Stmnts, Suppress => All_Checks);
|
|
|
177 Expand_Exception_Handlers (HSS);
|
|
|
178
|
|
|
179 if Present (Blk_Id) then
|
|
|
180 Pop_Scope;
|
|
|
181 end if;
|
|
|
182 end Expand_At_End_Handler;
|
|
|
183
|
|
|
184 -------------------------------
|
|
|
185 -- Expand_Exception_Handlers --
|
|
|
186 -------------------------------
|
|
|
187
|
|
|
188 procedure Expand_Exception_Handlers (HSS : Node_Id) is
|
|
|
189 Handlrs : constant List_Id := Exception_Handlers (HSS);
|
|
|
190 Loc : constant Source_Ptr := Sloc (HSS);
|
|
|
191 Handler : Node_Id;
|
|
|
192 Others_Choice : Boolean;
|
|
|
193 Obj_Decl : Node_Id;
|
|
|
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.
|
|
|
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
|
|
|
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
|
|
|
219 -- looks like this. Right now we have for example (where L1, L2 are
|
|
|
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
|
|
|
238 -- L1 : label; -- marked Exception_Junk
|
|
|
239 -- L2 : label; -- marked Exception_Junk
|
|
|
240 -- L3 : label; -- marked Exception_Junk
|
|
|
241
|
|
|
242 -- begin -- marked Exception_Junk
|
|
|
243 -- ...
|
|
|
244 -- local_raise (excep1'address); -- was raise excep1
|
|
|
245 -- goto L1;
|
|
|
246 -- ...
|
|
|
247 -- local_raise (excep2'address); -- was raise excep2
|
|
|
248 -- goto L2;
|
|
|
249 -- ...
|
|
|
250 -- exception
|
|
|
251 -- when excep1 =>
|
|
|
252 -- goto L1;
|
|
|
253 -- when excep2 =>
|
|
|
254 -- goto L2;
|
|
|
255 -- end;
|
|
|
256
|
|
|
257 -- goto L3; -- skip handler if no raise, marked Exception_Junk
|
|
|
258
|
|
|
259 -- <<L1>> -- local excep target label, marked Exception_Junk
|
|
|
260 -- begin -- marked Exception_Junk
|
|
|
261 -- estmts1
|
|
|
262 -- end;
|
|
|
263 -- goto L3; -- marked Exception_Junk
|
|
|
264
|
|
|
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
|
|
|
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
|
|
|
280 -- can omit the exception handlers.
|
|
|
281
|
|
|
282 -- begin
|
|
|
283 -- L1 : label; -- marked Exception_Junk
|
|
|
284 -- L2 : label; -- marked Exception_Junk
|
|
|
285 -- L3 : label; -- marked Exception_Junk
|
|
|
286
|
|
|
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;
|
|
|
296
|
|
|
297 -- goto L3; -- skip handler if no raise, marked Exception_Junk
|
|
|
298
|
|
|
299 -- <<L1>> -- local excep target label, marked Exception_Junk
|
|
|
300 -- begin -- marked Exception_Junk
|
|
|
301 -- estmts1
|
|
|
302 -- end;
|
|
|
303 -- goto L3; -- marked Exception_Junk
|
|
|
304
|
|
|
305 -- <<L2>> -- marked Exception_Junk
|
|
|
306 -- begin -- marked Exception_Junk
|
|
|
307 -- estmts2
|
|
|
308 -- end;
|
|
|
309
|
|
|
310 -- <<L3>> -- marked Exception_Junk
|
|
|
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
|
|
|
342 -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
|
|
|
343 -- left unchanged and passed to the back end.
|
|
|
344
|
|
|
345 -- Instead, the front end generates three nodes
|
|
|
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
|
|
|
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
|
|
|
371 -- The back end must maintain three stacks, one for each exception case,
|
|
|
372 -- the Push node pushes an entry onto the corresponding stack, and Pop
|
|
|
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
|
|
|
375 -- generated. This goto should be preceded by a call to Local_Raise as
|
|
|
376 -- described above.
|
|
|
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
|
|
|
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"]
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
443 procedure Add_Exception_Label (H : Node_Id);
|
|
|
444 -- H is an exception handler. First check for an Exception_Label
|
|
|
445 -- already allocated for H. If none, allocate one, set the field in
|
|
|
446 -- the handler node, add the label declaration, and set the flag
|
|
|
447 -- Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
|
|
|
448 -- the call has no effect and Exception_Label is left empty.
|
|
|
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)
|
|
|
478 and then not Special_Exception_Package_Used
|
|
|
479 then
|
|
|
480 Local_Expansion_Required := True;
|
|
|
481
|
|
|
482 declare
|
|
|
483 L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
|
|
|
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
|
|
|
517 if Restriction_Active (No_Exception_Handlers)
|
|
|
518 or else CodePeer_Mode
|
|
|
519 then
|
|
|
520 return;
|
|
|
521 end if;
|
|
|
522
|
|
|
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
|
|
|
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.
|
|
|
542
|
|
|
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));
|
|
|
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);
|
|
|
559 Stmts : List_Id := No_List;
|
|
|
560 Choice : Node_Id;
|
|
|
561 Excep : Entity_Id;
|
|
|
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
|
|
|
593 -- Start of processing for Expand_Local_Exception_Handlers
|
|
|
594
|
|
|
595 begin
|
|
|
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
|
|
|
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
|
|
|
618 -- to see if handler handles CE, PE, SE and if so generate the
|
|
|
619 -- appropriate push/pop sequence for the back end.
|
|
|
620
|
|
|
621 if (Debug_Flag_Dot_G
|
|
|
622 or else Restriction_Active (No_Exception_Propagation))
|
|
|
623 and then Has_Local_Raise (Handler)
|
|
|
624 then
|
|
|
625 Choice := First (Exception_Choices (Handler));
|
|
|
626 while Present (Choice) loop
|
|
|
627 if Nkind (Choice) = N_Others_Choice
|
|
|
628 and then not All_Others (Choice)
|
|
|
629 then
|
|
|
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
|
|
|
635 Excep := Get_Renamed_Entity (Entity (Choice));
|
|
|
636
|
|
|
637 if Excep = Standard_Constraint_Error then
|
|
|
638 Generate_Push_Pop_For_Constraint_Error (Handler);
|
|
|
639 elsif Excep = Standard_Program_Error then
|
|
|
640 Generate_Push_Pop_For_Program_Error (Handler);
|
|
|
641 elsif Excep = Standard_Storage_Error then
|
|
|
642 Generate_Push_Pop_For_Storage_Error (Handler);
|
|
|
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
|
|
|
662 -- L3 is the label to exit the HSS
|
|
|
663
|
|
|
664 L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
|
|
|
665
|
|
|
666 Labl_L3 : constant Node_Id :=
|
|
|
667 Make_Label (Loc,
|
|
|
668 Identifier => New_Occurrence_Of (L3_Dent, Loc));
|
|
|
669
|
|
|
670 Blk_Stm : Node_Id;
|
|
|
671 Relmt : Elmt_Id;
|
|
|
672
|
|
|
673 begin
|
|
|
674 Set_Exception_Junk (Labl_L3);
|
|
|
675 Add_Label_Declaration (L3_Dent);
|
|
|
676
|
|
|
677 -- Wrap existing statements and handlers in an inner block
|
|
|
678
|
|
|
679 Blk_Stm :=
|
|
|
680 Make_Block_Statement (Loc,
|
|
|
681 Handled_Statement_Sequence => Relocate_Node (HSS));
|
|
|
682 Set_Exception_Junk (Blk_Stm);
|
|
|
683
|
|
|
684 Rewrite (HSS,
|
|
|
685 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
686 Statements => New_List (Blk_Stm),
|
|
|
687 End_Label => Relocate_Node (End_Label (HSS))));
|
|
|
688
|
|
|
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.
|
|
|
692
|
|
|
693 Set_Analyzed (Blk_Stm);
|
|
|
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
|
|
|
707 -- L1 is the start label for this handler
|
|
|
708
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
727 -- Jump to L3 to be used at the end of handler
|
|
|
728
|
|
|
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
|
|
|
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
|
|
|
746 -- Replace handler by a goto L1. We can mark this as
|
|
|
747 -- analyzed since it is fully formed, and we don't
|
|
|
748 -- want it going through any further checks. We save
|
|
|
749 -- the last statement location in the goto L1 node for
|
|
|
750 -- the benefit of Sem_Ch6.Check_Returns.
|
|
|
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
|
|
|
762 Raise_S : constant Node_Id := Node (Relmt);
|
|
|
763 RLoc : constant Source_Ptr := Sloc (Raise_S);
|
|
|
764 Name_L1 : constant Node_Id :=
|
|
|
765 New_Occurrence_Of (L1_Dent, Loc);
|
|
|
766 Goto_L1 : constant Node_Id :=
|
|
|
767 Make_Goto_Statement (RLoc,
|
|
|
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
|
|
|
782 -- Add a goto L3 at end of statement list in block. The
|
|
|
783 -- first time, this is what skips over the exception
|
|
|
784 -- handlers in the normal case. Subsequent times, it
|
|
|
785 -- terminates the execution of the previous handler code,
|
|
|
786 -- and skips subsequent handlers.
|
|
|
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);
|
|
|
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;
|
|
|
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
|
|
|
816 -- case we have to generate possible diagnostics.
|
|
|
817
|
|
|
818 elsif Has_Local_Raise (Handler)
|
|
|
819 and then Local_Raise_Statements (Handler) /= No_Elist
|
|
|
820 then
|
|
|
821 Relmt := First_Elmt (Local_Raise_Statements (Handler));
|
|
|
822 while Present (Relmt) loop
|
|
|
823 Warn_If_No_Propagation (Node (Relmt));
|
|
|
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);
|
|
|
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
|
|
|
849 return;
|
|
|
850 end;
|
|
|
851 end Expand_Local_Exception_Handlers;
|
|
|
852
|
|
|
853 -----------------------------
|
|
|
854 -- Prepend_Call_To_Handler --
|
|
|
855 -----------------------------
|
|
|
856
|
|
|
857 procedure Prepend_Call_To_Handler
|
|
|
858 (Proc : RE_Id;
|
|
|
859 Args : List_Id := No_List)
|
|
|
860 is
|
|
|
861 Ent : constant Entity_Id := RTE (Proc);
|
|
|
862
|
|
|
863 begin
|
|
|
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.
|
|
|
868
|
|
|
869 if Present (Ent) then
|
|
|
870 declare
|
|
|
871 Call : constant Node_Id :=
|
|
|
872 Make_Procedure_Call_Statement (No_Location,
|
|
|
873 Name => New_Occurrence_Of (RTE (Proc), No_Location),
|
|
|
874 Parameter_Associations => Args);
|
|
|
875
|
|
|
876 begin
|
|
|
877 Prepend_To (Statements (Handler), Call);
|
|
|
878 Analyze (Call, Suppress => All_Checks);
|
|
|
879 end;
|
|
|
880 end if;
|
|
|
881 end Prepend_Call_To_Handler;
|
|
|
882
|
|
|
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
|
|
|
915 -- The only other possibility is a node that is or used to be a
|
|
131
|
916 -- simple raise statement. Note that the string expression in the
|
|
|
917 -- original Raise statement is ignored.
|
|
111
|
918
|
|
|
919 else
|
|
|
920 Orig := Original_Node (Raise_S);
|
|
|
921 pragma Assert (Nkind (Orig) = N_Raise_Statement
|
|
131
|
922 and then Present (Name (Orig)));
|
|
111
|
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
|
|
|
928 -- First prepare the call to Local_Raise (excep'address).
|
|
|
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 (
|
|
|
935 Unchecked_Convert_To (RTE (RE_Address),
|
|
|
936 Make_Attribute_Reference (Loc,
|
|
|
937 Prefix => New_Occurrence_Of (Excep, Loc),
|
|
|
938 Attribute_Name => Name_Identity))));
|
|
|
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))));
|
|
|
960 Set_Exception_Junk (Raise_S);
|
|
|
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
|
|
|
979 -- Start of processing for Expand_Exception_Handlers
|
|
|
980
|
|
|
981 begin
|
|
|
982 Expand_Local_Exception_Handlers;
|
|
|
983
|
|
|
984 -- Loop through handlers
|
|
|
985
|
|
|
986 Handler := First_Non_Pragma (Handlrs);
|
|
|
987 Handler_Loop : while Present (Handler) loop
|
|
|
988 Process_Statements_For_Controlled_Objects (Handler);
|
|
|
989
|
|
|
990 Next_Handler := Next_Non_Pragma (Handler);
|
|
|
991
|
|
|
992 -- Remove source handler if gnat debug flag .x is set
|
|
|
993
|
|
|
994 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
|
|
|
995 Remove (Handler);
|
|
|
996
|
|
|
997 -- Remove handler if no exception propagation, generating a warning
|
|
|
998 -- if a source generated handler was not the target of a local raise.
|
|
|
999
|
|
|
1000 else
|
|
|
1001 if not Has_Local_Raise (Handler)
|
|
|
1002 and then Comes_From_Source (Handler)
|
|
|
1003 then
|
|
|
1004 Warn_If_No_Local_Raise (Handler);
|
|
|
1005 end if;
|
|
|
1006
|
|
|
1007 if No_Exception_Propagation_Active then
|
|
|
1008 Remove (Handler);
|
|
|
1009
|
|
|
1010 -- Exception handler is active and retained and must be processed
|
|
|
1011
|
|
|
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
|
|
|
1015
|
|
|
1016 -- declare
|
|
|
1017 -- name : Exception_Occurrence;
|
|
|
1018 -- begin
|
|
|
1019 -- Save_Occurrence (name, Get_Current_Excep.all)
|
|
|
1020 -- ...
|
|
|
1021 -- end;
|
|
|
1022
|
|
|
1023 -- This expansion is only performed when using front-end
|
|
|
1024 -- exceptions. Gigi will insert a call to initialize the
|
|
|
1025 -- choice parameter.
|
|
|
1026
|
|
|
1027 if Present (Choice_Parameter (Handler))
|
|
|
1028 and then (Front_End_Exceptions
|
|
|
1029 or else CodePeer_Mode)
|
|
|
1030 then
|
|
|
1031 declare
|
|
|
1032 Cparm : constant Entity_Id := Choice_Parameter (Handler);
|
|
|
1033 Cloc : constant Source_Ptr := Sloc (Cparm);
|
|
|
1034 Hloc : constant Source_Ptr := Sloc (Handler);
|
|
|
1035 Save : Node_Id;
|
|
|
1036
|
|
|
1037 begin
|
|
|
1038 -- Note: No_Location used to hide code from the debugger,
|
|
|
1039 -- so single stepping doesn't jump back and forth.
|
|
|
1040
|
|
|
1041 Save :=
|
|
|
1042 Make_Procedure_Call_Statement (No_Location,
|
|
|
1043 Name =>
|
|
|
1044 New_Occurrence_Of
|
|
|
1045 (RTE (RE_Save_Occurrence), No_Location),
|
|
|
1046 Parameter_Associations => New_List (
|
|
|
1047 New_Occurrence_Of (Cparm, No_Location),
|
|
|
1048 Make_Explicit_Dereference (No_Location,
|
|
|
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))))));
|
|
|
1057
|
|
|
1058 Mark_Rewrite_Insertion (Save);
|
|
|
1059 Prepend (Save, Statements (Handler));
|
|
|
1060
|
|
|
1061 Obj_Decl :=
|
|
|
1062 Make_Object_Declaration (Cloc,
|
|
|
1063 Defining_Identifier => Cparm,
|
|
|
1064 Object_Definition =>
|
|
|
1065 New_Occurrence_Of
|
|
|
1066 (RTE (RE_Exception_Occurrence), Cloc));
|
|
|
1067 Set_No_Initialization (Obj_Decl, True);
|
|
|
1068
|
|
|
1069 Rewrite (Handler,
|
|
|
1070 Make_Exception_Handler (Hloc,
|
|
|
1071 Choice_Parameter => Empty,
|
|
|
1072 Exception_Choices => Exception_Choices (Handler),
|
|
|
1073 Statements => New_List (
|
|
|
1074 Make_Block_Statement (Hloc,
|
|
|
1075 Declarations => New_List (Obj_Decl),
|
|
|
1076 Handled_Statement_Sequence =>
|
|
|
1077 Make_Handled_Sequence_Of_Statements (Hloc,
|
|
|
1078 Statements => Statements (Handler))))));
|
|
|
1079
|
|
|
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
|
|
|
1088 Analyze_List
|
|
|
1089 (Statements (Handler), Suppress => All_Checks);
|
|
|
1090 end;
|
|
|
1091 end if;
|
|
|
1092
|
|
|
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
|
|
|
1101 and then not ZCX_Exceptions
|
|
|
1102 then
|
|
|
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))))
|
|
|
1126 then
|
|
|
1127 Prepend_Call_To_Handler (RE_Abort_Undefer);
|
|
|
1128 end if;
|
|
|
1129 end if;
|
|
|
1130 end if;
|
|
|
1131 end if;
|
|
|
1132
|
|
|
1133 Handler := Next_Handler;
|
|
|
1134 end loop Handler_Loop;
|
|
|
1135
|
|
|
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.
|
|
|
1139
|
|
|
1140 if Is_Empty_List (Handlrs) then
|
|
|
1141 Set_Exception_Handlers (Parent (Handlrs), No_List);
|
|
|
1142 end if;
|
|
|
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
|
|
|
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);
|
|
|
1159
|
|
|
1160 -- (protecting test only needed if not at library level)
|
|
|
1161
|
|
|
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
|
|
|
1169 Id : constant Entity_Id := Defining_Identifier (N);
|
|
|
1170 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1171
|
|
|
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
|
|
|
1200 function Null_String return String_Id;
|
|
|
1201 -- Build a null-terminated empty string
|
|
|
1202
|
|
|
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
|
|
|
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
|
|
|
1264 -- Start of processing for Expand_N_Exception_Declaration
|
|
|
1265
|
|
|
1266 begin
|
|
|
1267 -- Nothing to do when generating C code
|
|
|
1268
|
|
|
1269 if Modify_Tree_For_C then
|
|
|
1270 return;
|
|
|
1271 end if;
|
|
|
1272
|
|
|
1273 -- Definition of the external name: nam : constant String := "A.B.NAME";
|
|
|
1274
|
|
|
1275 Ex_Id :=
|
|
|
1276 Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E'));
|
|
|
1277
|
|
|
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
|
|
|
1291 Insert_Action (N,
|
|
|
1292 Make_Object_Declaration (Loc,
|
|
|
1293 Defining_Identifier => Ex_Id,
|
|
|
1294 Constant_Present => True,
|
|
|
1295 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
|
1296 Expression => Make_String_Literal (Loc, Ex_Val)));
|
|
|
1297
|
|
|
1298 Set_Is_Statically_Allocated (Ex_Id);
|
|
|
1299
|
|
|
1300 -- Create the aggregate list for type Standard.Exception_Type:
|
|
|
1301 -- Handled_By_Other component: False
|
|
|
1302
|
|
|
1303 L := Empty_List;
|
|
|
1304 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
|
|
|
1305
|
|
|
1306 -- Lang component: 'A'
|
|
|
1307
|
|
|
1308 Append_To (L,
|
|
|
1309 Make_Character_Literal (Loc,
|
|
145
|
1310 Chars => Name_uA,
|
|
|
1311 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
|
|
111
|
1312
|
|
|
1313 -- Name_Length component: Nam'Length
|
|
|
1314
|
|
|
1315 Append_To (L,
|
|
|
1316 Make_Attribute_Reference (Loc,
|
|
|
1317 Prefix => New_Occurrence_Of (Ex_Id, Loc),
|
|
|
1318 Attribute_Name => Name_Length));
|
|
|
1319
|
|
|
1320 -- Full_Name component: Standard.A_Char!(Nam'Address)
|
|
|
1321
|
|
|
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;
|
|
|
1334
|
|
|
1335 -- HTable_Ptr component: null
|
|
|
1336
|
|
|
1337 Append_To (L, Make_Null (Loc));
|
|
|
1338
|
|
|
1339 -- Foreign_Data component: null
|
|
|
1340
|
|
|
1341 Append_To (L, Make_Null (Loc));
|
|
|
1342
|
|
|
1343 -- Raise_Hook component: null
|
|
|
1344
|
|
|
1345 Append_To (L, Make_Null (Loc));
|
|
|
1346
|
|
|
1347 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
|
|
|
1348 Analyze_And_Resolve (Expression (N), Etype (Id));
|
|
|
1349
|
|
|
1350 Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
|
|
|
1351
|
|
|
1352 -- Register_Exception (except'Unchecked_Access);
|
|
|
1353
|
|
|
1354 if not No_Exception_Handlers_Set
|
|
|
1355 and then not Restriction_Active (No_Exception_Registration)
|
|
|
1356 then
|
|
|
1357 L := New_List (
|
|
|
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)))));
|
|
|
1366
|
|
|
1367 Set_Register_Exception_Call (Id, First (L));
|
|
|
1368
|
|
|
1369 if not Is_Library_Level_Entity (Id) then
|
|
|
1370 Flag_Id :=
|
|
|
1371 Make_Defining_Identifier (Loc,
|
|
|
1372 Chars => New_External_Name (Chars (Id), 'F'));
|
|
|
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;
|
|
|
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
|
|
|
1406 -- Expand exception handlers
|
|
|
1407
|
|
|
1408 if Present (Exception_Handlers (N))
|
|
|
1409 and then not Restriction_Active (No_Exception_Handlers)
|
|
|
1410 then
|
|
|
1411 Expand_Exception_Handlers (N);
|
|
|
1412 end if;
|
|
|
1413
|
|
|
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
|
|
131
|
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.
|
|
|
1428
|
|
|
1429 if not Nkind_In (Parent (N), N_Accept_Statement,
|
|
|
1430 N_Extended_Return_Statement,
|
|
|
1431 N_Package_Body)
|
|
111
|
1432 and then not Delay_Cleanups (Current_Scope)
|
|
|
1433 and then not Is_Thunk (Current_Scope)
|
|
|
1434 then
|
|
|
1435 Expand_Cleanup_Actions (Parent (N));
|
|
131
|
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
|
|
111
|
1444 else
|
|
|
1445 Set_First_Real_Statement (N, First (Statements (N)));
|
|
|
1446 end if;
|
|
|
1447 end Expand_N_Handled_Sequence_Of_Statements;
|
|
|
1448
|
|
|
1449 -------------------------------------
|
|
|
1450 -- Expand_N_Raise_Constraint_Error --
|
|
|
1451 -------------------------------------
|
|
|
1452
|
|
|
1453 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
|
|
|
1454 begin
|
|
|
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
|
|
|
1458 -- what strange optimization in future may require this adjustment.
|
|
|
1459
|
|
|
1460 Adjust_Condition (Condition (N));
|
|
|
1461
|
|
|
1462 -- Now deal with possible local raise handling
|
|
|
1463
|
|
|
1464 Possible_Local_Raise (N, Standard_Constraint_Error);
|
|
|
1465 end Expand_N_Raise_Constraint_Error;
|
|
|
1466
|
|
|
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
|
|
|
1477 Possible_Local_Raise (N, Entity (Name (N)));
|
|
|
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
|
|
|
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;
|
|
|
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
|
|
|
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;
|
|
|
1519
|
|
|
1520 Analyze_And_Resolve (N, Typ);
|
|
|
1521 end Expand_N_Raise_Expression;
|
|
|
1522
|
|
|
1523 ----------------------------------
|
|
|
1524 -- Expand_N_Raise_Program_Error --
|
|
|
1525 ----------------------------------
|
|
|
1526
|
|
|
1527 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
|
|
|
1528 begin
|
|
|
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
|
|
|
1532 -- what strange optimization in future may require this adjustment.
|
|
|
1533
|
|
|
1534 Adjust_Condition (Condition (N));
|
|
|
1535
|
|
|
1536 -- Now deal with possible local raise handling
|
|
|
1537
|
|
|
1538 Possible_Local_Raise (N, Standard_Program_Error);
|
|
|
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;
|
|
|
1550 H : Node_Id;
|
|
|
1551 Src : Boolean;
|
|
|
1552
|
|
|
1553 begin
|
|
|
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));
|
|
|
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);
|
|
|
1581 end if;
|
|
|
1582
|
|
|
1583 end if;
|
|
|
1584 end if;
|
|
|
1585
|
|
|
1586 -- If a string expression is present, then the raise statement is
|
|
|
1587 -- converted to a call:
|
|
|
1588 -- Raise_Exception (exception-name'Identity, string);
|
|
|
1589 -- and there is nothing else to do.
|
|
|
1590
|
|
|
1591 if Present (Expression (N)) then
|
|
|
1592
|
|
|
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
|
|
|
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;
|
|
|
1609 end if;
|
|
|
1610
|
|
|
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
|
|
|
1637 Analyze (N);
|
|
|
1638 return;
|
|
|
1639 end if;
|
|
|
1640
|
|
|
1641 -- Remaining processing is for the case where no string expression is
|
|
|
1642 -- present.
|
|
|
1643
|
|
|
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.
|
|
|
1647
|
|
|
1648 if Configurable_Run_Time_Violations > 0
|
|
|
1649 and then not Comes_From_Source (N)
|
|
|
1650 then
|
|
|
1651 return;
|
|
|
1652 end if;
|
|
|
1653
|
|
|
1654 -- Convert explicit raise of Program_Error, Constraint_Error, and
|
|
|
1655 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
|
|
|
1656 -- all other raises will get normal expansion and be disallowed,
|
|
|
1657 -- but this is also faster in all modes). Propagate Comes_From_Source
|
|
|
1658 -- flag to the new node.
|
|
|
1659
|
|
|
1660 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
|
|
|
1661 Src := Comes_From_Source (N);
|
|
|
1662
|
|
|
1663 if Entity (Name (N)) = Standard_Constraint_Error then
|
|
|
1664 Rewrite (N,
|
|
|
1665 Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
|
|
|
1666 Set_Comes_From_Source (N, Src);
|
|
|
1667 Analyze (N);
|
|
|
1668 return;
|
|
|
1669
|
|
|
1670 elsif Entity (Name (N)) = Standard_Program_Error then
|
|
|
1671 Rewrite (N,
|
|
|
1672 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
|
|
|
1673 Set_Comes_From_Source (N, Src);
|
|
|
1674 Analyze (N);
|
|
|
1675 return;
|
|
|
1676
|
|
|
1677 elsif Entity (Name (N)) = Standard_Storage_Error then
|
|
|
1678 Rewrite (N,
|
|
|
1679 Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
|
|
|
1680 Set_Comes_From_Source (N, Src);
|
|
|
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));
|
|
|
1695 Buf : Bounded_String;
|
|
|
1696
|
|
|
1697 begin
|
|
|
1698 Build_Location_String (Buf, Loc);
|
|
|
1699
|
|
|
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
|
|
|
1707 -- Build a C-compatible string in case of no exception handlers,
|
|
|
1708 -- since this is what the last chance handler is expecting.
|
|
|
1709
|
|
|
1710 if No_Exception_Handlers_Set then
|
|
|
1711
|
|
|
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
|
|
|
1716 Buf.Length := 0;
|
|
|
1717 end if;
|
|
|
1718
|
|
|
1719 Append (Buf, ASCII.NUL);
|
|
|
1720 end if;
|
|
|
1721
|
|
|
1722 if Opt.Exception_Locations_Suppressed then
|
|
|
1723 Buf.Length := 0;
|
|
|
1724 end if;
|
|
|
1725
|
|
|
1726 Str := String_From_Name_Buffer (Buf);
|
|
|
1727
|
|
|
1728 -- Convert raise to call to the Raise_Exception routine
|
|
|
1729
|
|
|
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))));
|
|
|
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
|
|
|
1749 -- Bypass expansion to a run-time call when back-end exception
|
|
|
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.
|
|
|
1754
|
|
|
1755 if not CodePeer_Mode
|
|
|
1756 and then Back_End_Exceptions
|
|
|
1757 then
|
|
|
1758 return;
|
|
|
1759 end if;
|
|
|
1760
|
|
|
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
|
|
|
1776 E := Make_Temporary (Loc, 'E');
|
|
|
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
|
|
|
1817 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
|
|
|
1818 begin
|
|
|
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
|
|
|
1822 -- what strange optimization in future may require this adjustment.
|
|
|
1823
|
|
|
1824 Adjust_Condition (Condition (N));
|
|
|
1825
|
|
|
1826 -- Now deal with possible local raise handling
|
|
|
1827
|
|
|
1828 Possible_Local_Raise (N, Standard_Storage_Error);
|
|
|
1829 end Expand_N_Raise_Storage_Error;
|
|
|
1830
|
|
|
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
|
|
|
1866 -- ??? Do not do it for the Call_Marker nodes inserted by the ABE
|
|
131
|
1867 -- mechanism because this generates too many false positives, or
|
|
|
1868 -- for generic instantiations for the same reason.
|
|
111
|
1869
|
|
|
1870 elsif Warn_On_Non_Local_Exception
|
|
|
1871 and then Restriction_Active (No_Exception_Propagation)
|
|
|
1872 and then Nkind (N) /= N_Call_Marker
|
|
131
|
1873 and then Nkind (N) not in N_Generic_Instantiation
|
|
111
|
1874 then
|
|
|
1875 Warn_No_Exception_Propagation_Active (N);
|
|
|
1876
|
|
|
1877 if Configurable_Run_Time_Mode then
|
|
|
1878 Error_Msg_NE
|
|
|
1879 ("\?X?& may call Last_Chance_Handler", N, E);
|
|
|
1880 else
|
|
|
1881 Error_Msg_NE
|
|
|
1882 ("\?X?& may result in unhandled exception", N, E);
|
|
|
1883 end if;
|
|
|
1884 end if;
|
|
|
1885 end;
|
|
|
1886 end Possible_Local_Raise;
|
|
|
1887
|
|
|
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
|
|
|
1901 SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
|
|
|
1902 -- This is used to test for wrapped actions below
|
|
|
1903
|
|
|
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
|
|
|
1910 -- Never any local handler if all handlers removed
|
|
|
1911
|
|
|
1912 if Debug_Flag_Dot_X then
|
|
|
1913 return Empty;
|
|
|
1914 end if;
|
|
|
1915
|
|
|
1916 -- Get the exception we are raising, allowing for renaming
|
|
|
1917
|
|
|
1918 ERaise := Get_Renamed_Entity (Ename);
|
|
|
1919
|
|
|
1920 -- We need to check if the node we are looking at is contained in
|
|
|
1921 --
|
|
|
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,
|
|
|
1930 -- protected body, or accept statement without having found a
|
|
|
1931 -- matching handler, then there is no local handler.
|
|
|
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
|
|
|
1938 or else Nkind (P) = N_Accept_Statement
|
|
|
1939 then
|
|
|
1940 return Empty;
|
|
|
1941
|
|
|
1942 -- Test for handled sequence of statements with at least one
|
|
|
1943 -- exception handler which might be the one we are looking for.
|
|
|
1944
|
|
|
1945 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
|
|
|
1946 and then Present (Exception_Handlers (P))
|
|
|
1947 then
|
|
|
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
|
|
|
1959 if Is_List_Member (N) then
|
|
|
1960 declare
|
|
|
1961 LCN : constant List_Id := List_Containing (N);
|
|
|
1962
|
|
|
1963 begin
|
|
|
1964 if LCN = Statements (P)
|
|
|
1965 or else
|
|
|
1966 LCN = SSE.Actions_To_Be_Wrapped (Before)
|
|
|
1967 or else
|
|
|
1968 LCN = SSE.Actions_To_Be_Wrapped (After)
|
|
|
1969 or else
|
|
|
1970 LCN = SSE.Actions_To_Be_Wrapped (Cleanup)
|
|
|
1971 then
|
|
|
1972 -- Loop through exception handlers
|
|
|
1973
|
|
|
1974 H := First (Exception_Handlers (P));
|
|
|
1975 while Present (H) loop
|
|
|
1976
|
|
|
1977 -- Guard against other constructs appearing in the
|
|
|
1978 -- list of exception handlers.
|
|
|
1979
|
|
|
1980 if Nkind (H) = N_Exception_Handler then
|
|
|
1981
|
|
|
1982 -- Loop through choices in one handler
|
|
|
1983
|
|
|
1984 C := First (Exception_Choices (H));
|
|
|
1985 while Present (C) loop
|
|
|
1986
|
|
|
1987 -- Deal with others case
|
|
|
1988
|
|
|
1989 if Nkind (C) = N_Others_Choice then
|
|
|
1990
|
|
|
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).
|
|
|
1996
|
|
|
1997 if No (Choice_Parameter (H)) then
|
|
|
1998 return H;
|
|
|
1999 else
|
|
|
2000 return Empty;
|
|
|
2001 end if;
|
|
|
2002
|
|
|
2003 -- If not others must be entity name
|
|
|
2004
|
|
|
2005 elsif Nkind (C) /= N_Others_Choice then
|
|
|
2006 pragma Assert (Is_Entity_Name (C));
|
|
|
2007 pragma Assert (Present (Entity (C)));
|
|
|
2008
|
|
|
2009 -- Get exception being handled, dealing with
|
|
|
2010 -- renaming.
|
|
|
2011
|
|
|
2012 EHandle := Get_Renamed_Entity (Entity (C));
|
|
|
2013
|
|
|
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;
|
|
|
2023 end if;
|
|
|
2024
|
|
|
2025 Next (C);
|
|
|
2026 end loop;
|
|
|
2027 end if;
|
|
|
2028
|
|
|
2029 Next (H);
|
|
|
2030 end loop;
|
|
|
2031 end if;
|
|
|
2032 end;
|
|
|
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
|
|
|
2044 -- Note: this is primarily provided for use by the back end in generating
|
|
|
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
|
|
|
2053 function Get_Local_Raise_Call_Entity return Entity_Id is
|
|
|
2054 begin
|
|
|
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;
|
|
|
2063 end if;
|
|
|
2064
|
|
|
2065 return Local_Raise_Call_Entity;
|
|
|
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
|
|
|
2074 case Rkind (R) is
|
|
|
2075 when CE_Reason => return Standard_Constraint_Error;
|
|
|
2076 when PE_Reason => return Standard_Program_Error;
|
|
|
2077 when SE_Reason => return Standard_Storage_Error;
|
|
|
2078 end case;
|
|
|
2079 end Get_RT_Exception_Entity;
|
|
|
2080
|
|
|
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");
|
|
|
2123 when PE_Aliased_Parameters =>
|
|
|
2124 Add_Str_To_Name_Buffer ("PE_Aliased_Parameters");
|
|
|
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");
|
|
131
|
2129 when PE_Build_In_Place_Mismatch =>
|
|
|
2130 Add_Str_To_Name_Buffer ("PE_Build_In_Place_Mismatch");
|
|
111
|
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");
|
|
|
2145 when PE_Non_Transportable_Actual =>
|
|
|
2146 Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual");
|
|
|
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");
|
|
|
2151 when PE_Stream_Operation_Not_Allowed =>
|
|
|
2152 Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed");
|
|
|
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");
|
|
|
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
|
|
|
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
|
|
|
2185 ----------------------------
|
|
|
2186 -- Warn_If_No_Propagation --
|
|
|
2187 ----------------------------
|
|
|
2188
|
|
|
2189 procedure Warn_If_No_Propagation (N : Node_Id) is
|
|
|
2190 begin
|
|
|
2191 if Restriction_Check_Required (No_Exception_Propagation)
|
|
|
2192 and then Warn_On_Non_Local_Exception
|
|
|
2193 then
|
|
|
2194 Warn_No_Exception_Propagation_Active (N);
|
|
|
2195
|
|
|
2196 if Configurable_Run_Time_Mode then
|
|
|
2197 Error_Msg_N
|
|
|
2198 ("\?X?Last_Chance_Handler will be called on exception", N);
|
|
|
2199 else
|
|
|
2200 Error_Msg_N
|
|
|
2201 ("\?X?execution may raise unhandled exception", N);
|
|
|
2202 end if;
|
|
|
2203 end if;
|
|
|
2204 end Warn_If_No_Propagation;
|
|
|
2205
|
|
|
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
|
|
|
2213 ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N);
|
|
|
2214 end Warn_No_Exception_Propagation_Active;
|
|
|
2215
|
|
|
2216 end Exp_Ch11;
|
