|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ 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 Checks; use Checks;
|
|
|
28 with Einfo; use Einfo;
|
|
|
29 with Errout; use Errout;
|
|
|
30 with Lib; use Lib;
|
|
|
31 with Lib.Xref; use Lib.Xref;
|
|
|
32 with Namet; use Namet;
|
|
|
33 with Nlists; use Nlists;
|
|
|
34 with Nmake; use Nmake;
|
|
|
35 with Opt; use Opt;
|
|
|
36 with Restrict; use Restrict;
|
|
|
37 with Rident; use Rident;
|
|
|
38 with Rtsfind; use Rtsfind;
|
|
|
39 with Sem; use Sem;
|
|
|
40 with Sem_Aux; use Sem_Aux;
|
|
|
41 with Sem_Ch5; use Sem_Ch5;
|
|
|
42 with Sem_Ch8; use Sem_Ch8;
|
|
|
43 with Sem_Ch13; use Sem_Ch13;
|
|
|
44 with Sem_Res; use Sem_Res;
|
|
|
45 with Sem_Util; use Sem_Util;
|
|
|
46 with Sem_Warn; use Sem_Warn;
|
|
|
47 with Sinfo; use Sinfo;
|
|
|
48 with Snames; use Snames;
|
|
|
49 with Stand; use Stand;
|
|
|
50
|
|
|
51 package body Sem_Ch11 is
|
|
|
52
|
|
|
53 -----------------------------------
|
|
|
54 -- Analyze_Exception_Declaration --
|
|
|
55 -----------------------------------
|
|
|
56
|
|
|
57 procedure Analyze_Exception_Declaration (N : Node_Id) is
|
|
|
58 Id : constant Entity_Id := Defining_Identifier (N);
|
|
|
59 PF : constant Boolean := Is_Pure (Current_Scope);
|
|
|
60
|
|
|
61 begin
|
|
|
62 Generate_Definition (Id);
|
|
|
63 Enter_Name (Id);
|
|
|
64 Set_Ekind (Id, E_Exception);
|
|
|
65 Set_Etype (Id, Standard_Exception_Type);
|
|
|
66 Set_Is_Statically_Allocated (Id);
|
|
|
67 Set_Is_Pure (Id, PF);
|
|
|
68
|
|
|
69 if Has_Aspects (N) then
|
|
|
70 Analyze_Aspect_Specifications (N, Id);
|
|
|
71 end if;
|
|
|
72 end Analyze_Exception_Declaration;
|
|
|
73
|
|
|
74 --------------------------------
|
|
|
75 -- Analyze_Exception_Handlers --
|
|
|
76 --------------------------------
|
|
|
77
|
|
|
78 procedure Analyze_Exception_Handlers (L : List_Id) is
|
|
|
79 Handler : Node_Id;
|
|
|
80 Choice : Entity_Id;
|
|
|
81 Id : Node_Id;
|
|
|
82 H_Scope : Entity_Id := Empty;
|
|
|
83
|
|
|
84 procedure Check_Duplication (Id : Node_Id);
|
|
|
85 -- Iterate through the identifiers in each handler to find duplicates
|
|
|
86
|
|
|
87 function Others_Present return Boolean;
|
|
|
88 -- Returns True if others handler is present
|
|
|
89
|
|
|
90 -----------------------
|
|
|
91 -- Check_Duplication --
|
|
|
92 -----------------------
|
|
|
93
|
|
|
94 procedure Check_Duplication (Id : Node_Id) is
|
|
|
95 Handler : Node_Id;
|
|
|
96 Id1 : Node_Id;
|
|
|
97 Id_Entity : Entity_Id := Entity (Id);
|
|
|
98
|
|
|
99 begin
|
|
|
100 if Present (Renamed_Entity (Id_Entity)) then
|
|
|
101 Id_Entity := Renamed_Entity (Id_Entity);
|
|
|
102 end if;
|
|
|
103
|
|
|
104 Handler := First_Non_Pragma (L);
|
|
|
105 while Present (Handler) loop
|
|
|
106 Id1 := First (Exception_Choices (Handler));
|
|
|
107 while Present (Id1) loop
|
|
|
108
|
|
|
109 -- Only check against the exception choices which precede
|
|
|
110 -- Id in the handler, since the ones that follow Id have not
|
|
|
111 -- been analyzed yet and will be checked in a subsequent call.
|
|
|
112
|
|
|
113 if Id = Id1 then
|
|
|
114 return;
|
|
|
115
|
|
|
116 elsif Nkind (Id1) /= N_Others_Choice
|
|
|
117 and then
|
|
|
118 (Id_Entity = Entity (Id1)
|
|
|
119 or else (Id_Entity = Renamed_Entity (Entity (Id1))))
|
|
|
120 then
|
|
|
121 if Handler /= Parent (Id) then
|
|
|
122 Error_Msg_Sloc := Sloc (Id1);
|
|
|
123 Error_Msg_NE ("exception choice duplicates &#", Id, Id1);
|
|
|
124
|
|
|
125 else
|
|
|
126 if Ada_Version = Ada_83
|
|
|
127 and then Comes_From_Source (Id)
|
|
|
128 then
|
|
|
129 Error_Msg_N
|
|
|
130 ("(Ada 83): duplicate exception choice&", Id);
|
|
|
131 end if;
|
|
|
132 end if;
|
|
|
133 end if;
|
|
|
134
|
|
|
135 Next_Non_Pragma (Id1);
|
|
|
136 end loop;
|
|
|
137
|
|
|
138 Next (Handler);
|
|
|
139 end loop;
|
|
|
140 end Check_Duplication;
|
|
|
141
|
|
|
142 --------------------
|
|
|
143 -- Others_Present --
|
|
|
144 --------------------
|
|
|
145
|
|
|
146 function Others_Present return Boolean is
|
|
|
147 H : Node_Id;
|
|
|
148
|
|
|
149 begin
|
|
|
150 H := First (L);
|
|
|
151 while Present (H) loop
|
|
|
152 if Nkind (H) /= N_Pragma
|
|
|
153 and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
|
|
|
154 then
|
|
|
155 return True;
|
|
|
156 end if;
|
|
|
157
|
|
|
158 Next (H);
|
|
|
159 end loop;
|
|
|
160
|
|
|
161 return False;
|
|
|
162 end Others_Present;
|
|
|
163
|
|
|
164 -- Start of processing for Analyze_Exception_Handlers
|
|
|
165
|
|
|
166 begin
|
|
|
167 Handler := First (L);
|
|
|
168
|
|
|
169 -- Pragma Restriction_Warnings has more related semantics than pragma
|
|
|
170 -- Restrictions in that it flags exception handlers as violators. Note
|
|
|
171 -- that the compiler must still generate handlers for certain critical
|
|
|
172 -- scenarios such as finalization. As a result, these handlers should
|
|
|
173 -- not be subjected to the restriction check when in warnings mode.
|
|
|
174
|
|
|
175 if not Comes_From_Source (Handler)
|
|
|
176 and then (Restriction_Warnings (No_Exception_Handlers)
|
|
|
177 or else Restriction_Warnings (No_Exception_Propagation)
|
|
|
178 or else Restriction_Warnings (No_Exceptions))
|
|
|
179 then
|
|
|
180 null;
|
|
|
181
|
|
|
182 else
|
|
|
183 Check_Restriction (No_Exceptions, Handler);
|
|
|
184 Check_Restriction (No_Exception_Handlers, Handler);
|
|
|
185 end if;
|
|
|
186
|
|
|
187 -- Kill current remembered values, since we don't know where we were
|
|
|
188 -- when the exception was raised.
|
|
|
189
|
|
|
190 Kill_Current_Values;
|
|
|
191
|
|
|
192 -- Loop through handlers (which can include pragmas)
|
|
|
193
|
|
|
194 while Present (Handler) loop
|
|
|
195
|
|
|
196 -- If pragma just analyze it
|
|
|
197
|
|
|
198 if Nkind (Handler) = N_Pragma then
|
|
|
199 Analyze (Handler);
|
|
|
200
|
|
|
201 -- Otherwise we have a real exception handler
|
|
|
202
|
|
|
203 else
|
|
|
204 -- Deal with choice parameter. The exception handler is a
|
|
|
205 -- declarative part for the choice parameter, so it constitutes a
|
|
|
206 -- scope for visibility purposes. We create an entity to denote
|
|
|
207 -- the whole exception part, and use it as the scope of all the
|
|
|
208 -- choices, which may even have the same name without conflict.
|
|
|
209 -- This scope plays no other role in expansion or code generation.
|
|
|
210
|
|
|
211 Choice := Choice_Parameter (Handler);
|
|
|
212
|
|
|
213 if Present (Choice) then
|
|
|
214 Set_Local_Raise_Not_OK (Handler);
|
|
|
215
|
|
|
216 if Comes_From_Source (Choice) then
|
|
|
217 Check_Restriction (No_Exception_Propagation, Choice);
|
|
|
218 Set_Debug_Info_Needed (Choice);
|
|
|
219 end if;
|
|
|
220
|
|
|
221 if No (H_Scope) then
|
|
|
222 H_Scope :=
|
|
|
223 New_Internal_Entity
|
|
|
224 (E_Block, Current_Scope, Sloc (Choice), 'E');
|
|
|
225 Set_Is_Exception_Handler (H_Scope);
|
|
|
226 end if;
|
|
|
227
|
|
|
228 Push_Scope (H_Scope);
|
|
|
229 Set_Etype (H_Scope, Standard_Void_Type);
|
|
|
230
|
|
|
231 Enter_Name (Choice);
|
|
|
232 Set_Ekind (Choice, E_Variable);
|
|
|
233
|
|
|
234 if RTE_Available (RE_Exception_Occurrence) then
|
|
|
235 Set_Etype (Choice, RTE (RE_Exception_Occurrence));
|
|
|
236 end if;
|
|
|
237
|
|
|
238 Generate_Definition (Choice);
|
|
|
239
|
|
|
240 -- Indicate that choice has an initial value, since in effect
|
|
|
241 -- this field is assigned an initial value by the exception.
|
|
|
242 -- We also consider that it is modified in the source.
|
|
|
243
|
|
|
244 Set_Has_Initial_Value (Choice, True);
|
|
|
245 Set_Never_Set_In_Source (Choice, False);
|
|
|
246 end if;
|
|
|
247
|
|
|
248 Id := First (Exception_Choices (Handler));
|
|
|
249 while Present (Id) loop
|
|
|
250 if Nkind (Id) = N_Others_Choice then
|
|
|
251 if Present (Next (Id))
|
|
|
252 or else Present (Next (Handler))
|
|
|
253 or else Present (Prev (Id))
|
|
|
254 then
|
|
|
255 Error_Msg_N ("OTHERS must appear alone and last", Id);
|
|
|
256 end if;
|
|
|
257
|
|
|
258 else
|
|
|
259 Analyze (Id);
|
|
|
260
|
|
|
261 -- In most cases the choice has already been analyzed in
|
|
|
262 -- Analyze_Handled_Statement_Sequence, in order to expand
|
|
|
263 -- local handlers. This advance analysis does not take into
|
|
|
264 -- account the case in which a choice has the same name as
|
|
|
265 -- the choice parameter of the handler, which may hide an
|
|
|
266 -- outer exception. This pathological case appears in ACATS
|
|
|
267 -- B80001_3.adb, and requires an explicit check to verify
|
|
|
268 -- that the id is not hidden.
|
|
|
269
|
|
|
270 if not Is_Entity_Name (Id)
|
|
|
271 or else Ekind (Entity (Id)) /= E_Exception
|
|
|
272 or else
|
|
|
273 (Nkind (Id) = N_Identifier
|
|
|
274 and then Chars (Id) = Chars (Choice))
|
|
|
275 then
|
|
|
276 Error_Msg_N ("exception name expected", Id);
|
|
|
277
|
|
|
278 else
|
|
|
279 -- Emit a warning at the declaration level when a local
|
|
|
280 -- exception is never raised explicitly.
|
|
|
281
|
|
|
282 if Warn_On_Redundant_Constructs
|
|
|
283 and then not Is_Raised (Entity (Id))
|
|
|
284 and then Scope (Entity (Id)) = Current_Scope
|
|
|
285 then
|
|
|
286 Error_Msg_NE
|
|
|
287 ("exception & is never raised?r?", Entity (Id), Id);
|
|
|
288 end if;
|
|
|
289
|
|
|
290 if Present (Renamed_Entity (Entity (Id))) then
|
|
|
291 if Entity (Id) = Standard_Numeric_Error then
|
|
|
292 Check_Restriction (No_Obsolescent_Features, Id);
|
|
|
293
|
|
|
294 if Warn_On_Obsolescent_Feature then
|
|
|
295 Error_Msg_N
|
|
|
296 ("Numeric_Error is an " &
|
|
|
297 "obsolescent feature (RM J.6(1))?j?", Id);
|
|
|
298 Error_Msg_N
|
|
|
299 ("\use Constraint_Error instead?j?", Id);
|
|
|
300 end if;
|
|
|
301 end if;
|
|
|
302 end if;
|
|
|
303
|
|
|
304 Check_Duplication (Id);
|
|
|
305
|
|
|
306 -- Check for exception declared within generic formal
|
|
|
307 -- package (which is illegal, see RM 11.2(8))
|
|
|
308
|
|
|
309 declare
|
|
|
310 Ent : Entity_Id := Entity (Id);
|
|
|
311 Scop : Entity_Id;
|
|
|
312
|
|
|
313 begin
|
|
|
314 if Present (Renamed_Entity (Ent)) then
|
|
|
315 Ent := Renamed_Entity (Ent);
|
|
|
316 end if;
|
|
|
317
|
|
|
318 Scop := Scope (Ent);
|
|
|
319 while Scop /= Standard_Standard
|
|
|
320 and then Ekind (Scop) = E_Package
|
|
|
321 loop
|
|
|
322 if Nkind (Declaration_Node (Scop)) =
|
|
|
323 N_Package_Specification
|
|
|
324 and then
|
|
|
325 Nkind (Original_Node (Parent
|
|
|
326 (Declaration_Node (Scop)))) =
|
|
|
327 N_Formal_Package_Declaration
|
|
|
328 then
|
|
|
329 Error_Msg_NE
|
|
|
330 ("exception& is declared in generic formal "
|
|
|
331 & "package", Id, Ent);
|
|
|
332 Error_Msg_N
|
|
|
333 ("\and therefore cannot appear in handler "
|
|
|
334 & "(RM 11.2(8))", Id);
|
|
|
335 exit;
|
|
|
336
|
|
|
337 -- If the exception is declared in an inner
|
|
|
338 -- instance, nothing else to check.
|
|
|
339
|
|
|
340 elsif Is_Generic_Instance (Scop) then
|
|
|
341 exit;
|
|
|
342 end if;
|
|
|
343
|
|
|
344 Scop := Scope (Scop);
|
|
|
345 end loop;
|
|
|
346 end;
|
|
|
347 end if;
|
|
|
348 end if;
|
|
|
349
|
|
|
350 Next (Id);
|
|
|
351 end loop;
|
|
|
352
|
|
|
353 -- Check for redundant handler (has only raise statement) and is
|
|
|
354 -- either an others handler, or is a specific handler when no
|
|
|
355 -- others handler is present.
|
|
|
356
|
|
|
357 if Warn_On_Redundant_Constructs
|
|
|
358 and then List_Length (Statements (Handler)) = 1
|
|
|
359 and then Nkind (First (Statements (Handler))) = N_Raise_Statement
|
|
|
360 and then No (Name (First (Statements (Handler))))
|
|
|
361 and then (not Others_Present
|
|
|
362 or else Nkind (First (Exception_Choices (Handler))) =
|
|
|
363 N_Others_Choice)
|
|
|
364 then
|
|
|
365 Error_Msg_N
|
|
|
366 ("useless handler contains only a reraise statement?r?",
|
|
|
367 Handler);
|
|
|
368 end if;
|
|
|
369
|
|
|
370 -- Now analyze the statements of this handler
|
|
|
371
|
|
|
372 Analyze_Statements (Statements (Handler));
|
|
|
373
|
|
|
374 -- If a choice was present, we created a special scope for it, so
|
|
|
375 -- this is where we pop that special scope to get rid of it.
|
|
|
376
|
|
|
377 if Present (Choice) then
|
|
|
378 End_Scope;
|
|
|
379 end if;
|
|
|
380 end if;
|
|
|
381
|
|
|
382 Next (Handler);
|
|
|
383 end loop;
|
|
|
384 end Analyze_Exception_Handlers;
|
|
|
385
|
|
|
386 --------------------------------
|
|
|
387 -- Analyze_Handled_Statements --
|
|
|
388 --------------------------------
|
|
|
389
|
|
|
390 procedure Analyze_Handled_Statements (N : Node_Id) is
|
|
|
391 Handlers : constant List_Id := Exception_Handlers (N);
|
|
|
392 Handler : Node_Id;
|
|
|
393 Choice : Node_Id;
|
|
|
394
|
|
|
395 begin
|
|
|
396 if Present (Handlers) then
|
|
|
397 Kill_All_Checks;
|
|
|
398 end if;
|
|
|
399
|
|
|
400 -- We are now going to analyze the statements and then the exception
|
|
|
401 -- handlers. We certainly need to do things in this order to get the
|
|
|
402 -- proper sequential semantics for various warnings.
|
|
|
403
|
|
|
404 -- However, there is a glitch. When we process raise statements, an
|
|
|
405 -- optimization is to look for local handlers and specialize the code
|
|
|
406 -- in this case.
|
|
|
407
|
|
|
408 -- In order to detect if a handler is matching, we must have at least
|
|
|
409 -- analyzed the choices in the proper scope so that proper visibility
|
|
|
410 -- analysis is performed. Hence we analyze just the choices first,
|
|
|
411 -- before we analyze the statement sequence.
|
|
|
412
|
|
|
413 Handler := First_Non_Pragma (Handlers);
|
|
|
414 while Present (Handler) loop
|
|
|
415 Choice := First_Non_Pragma (Exception_Choices (Handler));
|
|
|
416 while Present (Choice) loop
|
|
|
417 Analyze (Choice);
|
|
|
418 Next_Non_Pragma (Choice);
|
|
|
419 end loop;
|
|
|
420
|
|
|
421 Next_Non_Pragma (Handler);
|
|
|
422 end loop;
|
|
|
423
|
|
|
424 -- Analyze statements in sequence
|
|
|
425
|
|
|
426 Analyze_Statements (Statements (N));
|
|
|
427
|
|
|
428 -- If the current scope is a subprogram, entry or task body or declare
|
|
|
429 -- block then this is the right place to check for hanging useless
|
|
|
430 -- assignments from the statement sequence. Skip this in the body of a
|
|
|
431 -- postcondition, since in that case there are no source references, and
|
|
|
432 -- we need to preserve deferred references from the enclosing scope.
|
|
|
433
|
|
|
434 if ((Is_Subprogram (Current_Scope) or else Is_Entry (Current_Scope))
|
|
|
435 and then Chars (Current_Scope) /= Name_uPostconditions)
|
|
|
436 or else Ekind_In (Current_Scope, E_Block, E_Task_Type)
|
|
|
437 then
|
|
|
438 Warn_On_Useless_Assignments (Current_Scope);
|
|
|
439 end if;
|
|
|
440
|
|
|
441 -- Deal with handlers or AT END proc
|
|
|
442
|
|
|
443 if Present (Handlers) then
|
|
|
444 Analyze_Exception_Handlers (Handlers);
|
|
|
445 elsif Present (At_End_Proc (N)) then
|
|
|
446 Analyze (At_End_Proc (N));
|
|
|
447 end if;
|
|
|
448 end Analyze_Handled_Statements;
|
|
|
449
|
|
|
450 ------------------------------
|
|
|
451 -- Analyze_Raise_Expression --
|
|
|
452 ------------------------------
|
|
|
453
|
|
|
454 procedure Analyze_Raise_Expression (N : Node_Id) is
|
|
|
455 Exception_Id : constant Node_Id := Name (N);
|
|
|
456 Exception_Name : Entity_Id := Empty;
|
|
|
457
|
|
|
458 begin
|
|
|
459 if Comes_From_Source (N) then
|
|
|
460 Check_Compiler_Unit ("raise expression", N);
|
|
|
461 end if;
|
|
|
462
|
|
|
463 Check_SPARK_05_Restriction ("raise expression is not allowed", N);
|
|
|
464
|
|
|
465 -- Check exception restrictions on the original source
|
|
|
466
|
|
|
467 if Comes_From_Source (N) then
|
|
|
468 Check_Restriction (No_Exceptions, N);
|
|
|
469 end if;
|
|
|
470
|
|
|
471 Analyze (Exception_Id);
|
|
|
472
|
|
|
473 if Is_Entity_Name (Exception_Id) then
|
|
|
474 Exception_Name := Entity (Exception_Id);
|
|
|
475 end if;
|
|
|
476
|
|
|
477 if No (Exception_Name)
|
|
|
478 or else Ekind (Exception_Name) /= E_Exception
|
|
|
479 then
|
|
|
480 Error_Msg_N
|
|
|
481 ("exception name expected in raise statement", Exception_Id);
|
|
|
482 else
|
|
|
483 Set_Is_Raised (Exception_Name);
|
|
|
484 end if;
|
|
|
485
|
|
|
486 -- Deal with RAISE WITH case
|
|
|
487
|
|
|
488 if Present (Expression (N)) then
|
|
|
489 Analyze_And_Resolve (Expression (N), Standard_String);
|
|
|
490 end if;
|
|
|
491
|
|
|
492 -- Check obsolescent use of Numeric_Error
|
|
|
493
|
|
|
494 if Exception_Name = Standard_Numeric_Error then
|
|
|
495 Check_Restriction (No_Obsolescent_Features, Exception_Id);
|
|
|
496 end if;
|
|
|
497
|
|
|
498 -- Kill last assignment indication
|
|
|
499
|
|
|
500 Kill_Current_Values (Last_Assignment_Only => True);
|
|
|
501
|
|
|
502 -- Raise_Type is compatible with all other types so that the raise
|
|
|
503 -- expression is legal in any expression context. It will be eventually
|
|
|
504 -- replaced by the concrete type imposed by the context.
|
|
|
505
|
|
|
506 Set_Etype (N, Raise_Type);
|
|
|
507 end Analyze_Raise_Expression;
|
|
|
508
|
|
|
509 -----------------------------
|
|
|
510 -- Analyze_Raise_Statement --
|
|
|
511 -----------------------------
|
|
|
512
|
|
|
513 procedure Analyze_Raise_Statement (N : Node_Id) is
|
|
|
514 Exception_Id : constant Node_Id := Name (N);
|
|
|
515 Exception_Name : Entity_Id := Empty;
|
|
|
516 P : Node_Id;
|
|
|
517 Par : Node_Id;
|
|
|
518
|
|
|
519 begin
|
|
|
520 if Comes_From_Source (N) then
|
|
|
521 Check_SPARK_05_Restriction ("raise statement is not allowed", N);
|
|
|
522 end if;
|
|
|
523
|
|
|
524 Check_Unreachable_Code (N);
|
|
|
525
|
|
|
526 -- Check exception restrictions on the original source
|
|
|
527
|
|
|
528 if Comes_From_Source (N) then
|
|
|
529 Check_Restriction (No_Exceptions, N);
|
|
|
530 end if;
|
|
|
531
|
|
|
532 -- Check for useless assignment to OUT or IN OUT scalar preceding the
|
|
|
533 -- raise. Right now only look at assignment statements, could do more???
|
|
|
534
|
|
|
535 if Is_List_Member (N) then
|
|
|
536 declare
|
|
|
537 P : Node_Id;
|
|
|
538 L : Node_Id;
|
|
|
539
|
|
|
540 begin
|
|
|
541 P := Prev (N);
|
|
|
542
|
|
|
543 -- Skip past null statements and pragmas
|
|
|
544
|
|
|
545 while Present (P)
|
|
|
546 and then Nkind_In (P, N_Null_Statement, N_Pragma)
|
|
|
547 loop
|
|
|
548 P := Prev (P);
|
|
|
549 end loop;
|
|
|
550
|
|
|
551 -- See if preceding statement is an assignment
|
|
|
552
|
|
|
553 if Present (P) and then Nkind (P) = N_Assignment_Statement then
|
|
|
554 L := Name (P);
|
|
|
555
|
|
|
556 -- Give warning for assignment to scalar formal
|
|
|
557
|
|
|
558 if Is_Scalar_Type (Etype (L))
|
|
|
559 and then Is_Entity_Name (L)
|
|
|
560 and then Is_Formal (Entity (L))
|
|
|
561
|
|
|
562 -- Do this only for parameters to the current subprogram.
|
|
|
563 -- This avoids some false positives for the nested case.
|
|
|
564
|
|
|
565 and then Nearest_Dynamic_Scope (Current_Scope) =
|
|
|
566 Scope (Entity (L))
|
|
|
567
|
|
|
568 then
|
|
|
569 -- Don't give warning if we are covered by an exception
|
|
|
570 -- handler, since this may result in false positives, since
|
|
|
571 -- the handler may handle the exception and return normally.
|
|
|
572
|
|
|
573 -- First find the enclosing handled sequence of statements
|
|
|
574 -- (note, we could also look for a handler in an outer block
|
|
|
575 -- but currently we don't, and in that case we'll emit the
|
|
|
576 -- warning).
|
|
|
577
|
|
|
578 Par := N;
|
|
|
579 loop
|
|
|
580 Par := Parent (Par);
|
|
|
581 exit when Nkind (Par) = N_Handled_Sequence_Of_Statements;
|
|
|
582 end loop;
|
|
|
583
|
|
|
584 -- See if there is a handler, give message if not
|
|
|
585
|
|
|
586 if No (Exception_Handlers (Par)) then
|
|
|
587 Error_Msg_N
|
|
|
588 ("assignment to pass-by-copy formal "
|
|
|
589 & "may have no effect??", P);
|
|
|
590 Error_Msg_N
|
|
|
591 ("\RAISE statement may result in abnormal return "
|
|
|
592 & "(RM 6.4.1(17))??", P);
|
|
|
593 end if;
|
|
|
594 end if;
|
|
|
595 end if;
|
|
|
596 end;
|
|
|
597 end if;
|
|
|
598
|
|
|
599 -- Reraise statement
|
|
|
600
|
|
|
601 if No (Exception_Id) then
|
|
|
602 P := Parent (N);
|
|
|
603 while not Nkind_In (P, N_Exception_Handler,
|
|
|
604 N_Subprogram_Body,
|
|
|
605 N_Package_Body,
|
|
|
606 N_Task_Body,
|
|
|
607 N_Entry_Body)
|
|
|
608 loop
|
|
|
609 P := Parent (P);
|
|
|
610 end loop;
|
|
|
611
|
|
|
612 if Nkind (P) /= N_Exception_Handler then
|
|
|
613 Error_Msg_N
|
|
|
614 ("reraise statement must appear directly in a handler", N);
|
|
|
615
|
|
|
616 -- If a handler has a reraise, it cannot be the target of a local
|
|
|
617 -- raise (goto optimization is impossible), and if the no exception
|
|
|
618 -- propagation restriction is set, this is a violation.
|
|
|
619
|
|
|
620 else
|
|
|
621 Set_Local_Raise_Not_OK (P);
|
|
|
622
|
|
|
623 -- Do not check the restriction if the reraise statement is part
|
|
|
624 -- of the code generated for an AT-END handler. That's because
|
|
|
625 -- if the restriction is actually active, we never generate this
|
|
|
626 -- raise anyway, so the apparent violation is bogus.
|
|
|
627
|
|
|
628 if not From_At_End (N) then
|
|
|
629 Check_Restriction (No_Exception_Propagation, N);
|
|
|
630 end if;
|
|
|
631 end if;
|
|
|
632
|
|
|
633 -- Normal case with exception id present
|
|
|
634
|
|
|
635 else
|
|
|
636 Analyze (Exception_Id);
|
|
|
637
|
|
|
638 if Is_Entity_Name (Exception_Id) then
|
|
|
639 Exception_Name := Entity (Exception_Id);
|
|
|
640 end if;
|
|
|
641
|
|
|
642 if No (Exception_Name)
|
|
|
643 or else Ekind (Exception_Name) /= E_Exception
|
|
|
644 then
|
|
|
645 Error_Msg_N
|
|
|
646 ("exception name expected in raise statement", Exception_Id);
|
|
|
647 else
|
|
|
648 Set_Is_Raised (Exception_Name);
|
|
|
649 end if;
|
|
|
650
|
|
|
651 -- Deal with RAISE WITH case
|
|
|
652
|
|
|
653 if Present (Expression (N)) then
|
|
|
654 Analyze_And_Resolve (Expression (N), Standard_String);
|
|
|
655 end if;
|
|
|
656 end if;
|
|
|
657
|
|
|
658 -- Check obsolescent use of Numeric_Error
|
|
|
659
|
|
|
660 if Exception_Name = Standard_Numeric_Error then
|
|
|
661 Check_Restriction (No_Obsolescent_Features, Exception_Id);
|
|
|
662 end if;
|
|
|
663
|
|
|
664 -- Kill last assignment indication
|
|
|
665
|
|
|
666 Kill_Current_Values (Last_Assignment_Only => True);
|
|
|
667 end Analyze_Raise_Statement;
|
|
|
668
|
|
|
669 -----------------------------
|
|
|
670 -- Analyze_Raise_xxx_Error --
|
|
|
671 -----------------------------
|
|
|
672
|
|
|
673 -- Normally, the Etype is already set (when this node is used within
|
|
|
674 -- an expression, since it is copied from the node which it rewrites).
|
|
|
675 -- If this node is used in a statement context, then we set the type
|
|
|
676 -- Standard_Void_Type. This is used both by Gigi and by the front end
|
|
|
677 -- to distinguish the statement use and the subexpression use.
|
|
|
678
|
|
|
679 -- The only other required processing is to take care of the Condition
|
|
|
680 -- field if one is present.
|
|
|
681
|
|
|
682 procedure Analyze_Raise_xxx_Error (N : Node_Id) is
|
|
|
683
|
|
|
684 function Same_Expression (C1, C2 : Node_Id) return Boolean;
|
|
|
685 -- It often occurs that two identical raise statements are generated in
|
|
|
686 -- succession (for example when dynamic elaboration checks take place on
|
|
|
687 -- separate expressions in a call). If the two statements are identical
|
|
|
688 -- according to the simple criterion that follows, the raise is
|
|
|
689 -- converted into a null statement.
|
|
|
690
|
|
|
691 ---------------------
|
|
|
692 -- Same_Expression --
|
|
|
693 ---------------------
|
|
|
694
|
|
|
695 function Same_Expression (C1, C2 : Node_Id) return Boolean is
|
|
|
696 begin
|
|
|
697 if No (C1) and then No (C2) then
|
|
|
698 return True;
|
|
|
699
|
|
|
700 elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
|
|
|
701 return Entity (C1) = Entity (C2);
|
|
|
702
|
|
|
703 elsif Nkind (C1) /= Nkind (C2) then
|
|
|
704 return False;
|
|
|
705
|
|
|
706 elsif Nkind (C1) in N_Unary_Op then
|
|
|
707 return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
|
|
708
|
|
|
709 elsif Nkind (C1) in N_Binary_Op then
|
|
|
710 return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
|
|
|
711 and then
|
|
|
712 Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
|
|
|
713
|
|
|
714 elsif Nkind (C1) = N_Null then
|
|
|
715 return True;
|
|
|
716
|
|
|
717 else
|
|
|
718 return False;
|
|
|
719 end if;
|
|
|
720 end Same_Expression;
|
|
|
721
|
|
|
722 -- Start of processing for Analyze_Raise_xxx_Error
|
|
|
723
|
|
|
724 begin
|
|
|
725 if Nkind (Original_Node (N)) = N_Raise_Statement then
|
|
|
726 Check_SPARK_05_Restriction ("raise statement is not allowed", N);
|
|
|
727 end if;
|
|
|
728
|
|
|
729 if No (Etype (N)) then
|
|
|
730 Set_Etype (N, Standard_Void_Type);
|
|
|
731 end if;
|
|
|
732
|
|
|
733 if Present (Condition (N)) then
|
|
|
734 Analyze_And_Resolve (Condition (N), Standard_Boolean);
|
|
|
735 end if;
|
|
|
736
|
|
|
737 -- Deal with static cases in obvious manner
|
|
|
738
|
|
|
739 if Nkind (Condition (N)) = N_Identifier then
|
|
|
740 if Entity (Condition (N)) = Standard_True then
|
|
|
741 Set_Condition (N, Empty);
|
|
|
742
|
|
|
743 elsif Entity (Condition (N)) = Standard_False then
|
|
|
744 Rewrite (N, Make_Null_Statement (Sloc (N)));
|
|
|
745 end if;
|
|
|
746 end if;
|
|
|
747
|
|
|
748 -- Remove duplicate raise statements. Note that the previous one may
|
|
|
749 -- already have been removed as well.
|
|
|
750
|
|
|
751 if not Comes_From_Source (N)
|
|
|
752 and then Nkind (N) /= N_Null_Statement
|
|
|
753 and then Is_List_Member (N)
|
|
|
754 and then Present (Prev (N))
|
|
|
755 and then Nkind (N) = Nkind (Original_Node (Prev (N)))
|
|
|
756 and then Same_Expression
|
|
|
757 (Condition (N), Condition (Original_Node (Prev (N))))
|
|
|
758 then
|
|
|
759 Rewrite (N, Make_Null_Statement (Sloc (N)));
|
|
|
760 end if;
|
|
|
761 end Analyze_Raise_xxx_Error;
|
|
|
762
|
|
|
763 end Sem_Ch11;
|
