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