1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
31 with Lib
.Xref
; use Lib
.Xref
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
34 with Nmake
; use Nmake
;
36 with Restrict
; use Restrict
;
37 with Rident
; use Rident
;
38 with Rtsfind
; use Rtsfind
;
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 Stand
; use Stand
;
49 with Uintp
; use Uintp
;
51 package body Sem_Ch11
is
53 -----------------------------------
54 -- Analyze_Exception_Declaration --
55 -----------------------------------
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
);
61 Generate_Definition
(Id
);
63 Set_Ekind
(Id
, E_Exception
);
64 Set_Exception_Code
(Id
, Uint_0
);
65 Set_Etype
(Id
, Standard_Exception_Type
);
66 Set_Is_Statically_Allocated
(Id
);
69 if Has_Aspects
(N
) then
70 Analyze_Aspect_Specifications
(N
, Id
);
72 end Analyze_Exception_Declaration
;
74 --------------------------------
75 -- Analyze_Exception_Handlers --
76 --------------------------------
78 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
82 H_Scope
: Entity_Id
:= Empty
;
84 procedure Check_Duplication
(Id
: Node_Id
);
85 -- Iterate through the identifiers in each handler to find duplicates
87 function Others_Present
return Boolean;
88 -- Returns True if others handler is present
90 -----------------------
91 -- Check_Duplication --
92 -----------------------
94 procedure Check_Duplication
(Id
: Node_Id
) is
97 Id_Entity
: Entity_Id
:= Entity
(Id
);
100 if Present
(Renamed_Entity
(Id_Entity
)) then
101 Id_Entity
:= Renamed_Entity
(Id_Entity
);
104 Handler
:= First_Non_Pragma
(L
);
105 while Present
(Handler
) loop
106 Id1
:= First
(Exception_Choices
(Handler
));
107 while Present
(Id1
) loop
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.
116 elsif Nkind
(Id1
) /= N_Others_Choice
118 (Id_Entity
= Entity
(Id1
)
119 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
121 if Handler
/= Parent
(Id
) then
122 Error_Msg_Sloc
:= Sloc
(Id1
);
124 ("exception choice duplicates &#", Id
, Id1
);
127 if Ada_Version
= Ada_83
128 and then Comes_From_Source
(Id
)
131 ("(Ada 83): duplicate exception choice&", Id
);
136 Next_Non_Pragma
(Id1
);
141 end Check_Duplication
;
147 function Others_Present
return Boolean is
152 while Present
(H
) loop
153 if Nkind
(H
) /= N_Pragma
154 and then Nkind
(First
(Exception_Choices
(H
))) = N_Others_Choice
165 -- Start of processing for Analyze_Exception_Handlers
168 Handler
:= First
(L
);
169 Check_Restriction
(No_Exceptions
, Handler
);
170 Check_Restriction
(No_Exception_Handlers
, Handler
);
172 -- Kill current remembered values, since we don't know where we were
173 -- when the exception was raised.
177 -- Loop through handlers (which can include pragmas)
179 while Present
(Handler
) loop
181 -- If pragma just analyze it
183 if Nkind
(Handler
) = N_Pragma
then
186 -- Otherwise we have a real exception handler
189 -- Deal with choice parameter. The exception handler is a
190 -- declarative part for the choice parameter, so it constitutes a
191 -- scope for visibility purposes. We create an entity to denote
192 -- the whole exception part, and use it as the scope of all the
193 -- choices, which may even have the same name without conflict.
194 -- This scope plays no other role in expansion or code generation.
196 Choice
:= Choice_Parameter
(Handler
);
198 if Present
(Choice
) then
199 Set_Local_Raise_Not_OK
(Handler
);
201 if Comes_From_Source
(Choice
) then
202 Check_Restriction
(No_Exception_Propagation
, Choice
);
203 Set_Debug_Info_Needed
(Choice
);
209 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
212 Push_Scope
(H_Scope
);
213 Set_Etype
(H_Scope
, Standard_Void_Type
);
216 Set_Ekind
(Choice
, E_Variable
);
218 if RTE_Available
(RE_Exception_Occurrence
) then
219 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
222 Generate_Definition
(Choice
);
224 -- Indicate that choice has an initial value, since in effect
225 -- this field is assigned an initial value by the exception.
226 -- We also consider that it is modified in the source.
228 Set_Has_Initial_Value
(Choice
, True);
229 Set_Never_Set_In_Source
(Choice
, False);
232 Id
:= First
(Exception_Choices
(Handler
));
233 while Present
(Id
) loop
234 if Nkind
(Id
) = N_Others_Choice
then
235 if Present
(Next
(Id
))
236 or else Present
(Next
(Handler
))
237 or else Present
(Prev
(Id
))
239 Error_Msg_N
("OTHERS must appear alone and last", Id
);
245 -- In most cases the choice has already been analyzed in
246 -- Analyze_Handled_Statement_Sequence, in order to expand
247 -- local handlers. This advance analysis does not take into
248 -- account the case in which a choice has the same name as
249 -- the choice parameter of the handler, which may hide an
250 -- outer exception. This pathological case appears in ACATS
251 -- B80001_3.adb, and requires an explicit check to verify
252 -- that the id is not hidden.
254 if not Is_Entity_Name
(Id
)
255 or else Ekind
(Entity
(Id
)) /= E_Exception
257 (Nkind
(Id
) = N_Identifier
258 and then Chars
(Id
) = Chars
(Choice
))
260 Error_Msg_N
("exception name expected", Id
);
263 -- Emit a warning at the declaration level when a local
264 -- exception is never raised explicitly.
266 if Warn_On_Redundant_Constructs
267 and then not Is_Raised
(Entity
(Id
))
268 and then Scope
(Entity
(Id
)) = Current_Scope
271 ("exception & is never raised?r?", Entity
(Id
), Id
);
274 if Present
(Renamed_Entity
(Entity
(Id
))) then
275 if Entity
(Id
) = Standard_Numeric_Error
then
276 Check_Restriction
(No_Obsolescent_Features
, Id
);
278 if Warn_On_Obsolescent_Feature
then
280 ("Numeric_Error is an " &
281 "obsolescent feature (RM J.6(1))?j?", Id
);
283 ("\use Constraint_Error instead?j?", Id
);
288 Check_Duplication
(Id
);
290 -- Check for exception declared within generic formal
291 -- package (which is illegal, see RM 11.2(8))
294 Ent
: Entity_Id
:= Entity
(Id
);
298 if Present
(Renamed_Entity
(Ent
)) then
299 Ent
:= Renamed_Entity
(Ent
);
303 while Scop
/= Standard_Standard
304 and then Ekind
(Scop
) = E_Package
306 if Nkind
(Declaration_Node
(Scop
)) =
307 N_Package_Specification
309 Nkind
(Original_Node
(Parent
310 (Declaration_Node
(Scop
)))) =
311 N_Formal_Package_Declaration
314 ("exception& is declared in " &
315 "generic formal package", Id
, Ent
);
317 ("\and therefore cannot appear in " &
318 "handler (RM 11.2(8))", Id
);
321 -- If the exception is declared in an inner
322 -- instance, nothing else to check.
324 elsif Is_Generic_Instance
(Scop
) then
328 Scop
:= Scope
(Scop
);
337 -- Check for redundant handler (has only raise statement) and is
338 -- either an others handler, or is a specific handler when no
339 -- others handler is present.
341 if Warn_On_Redundant_Constructs
342 and then List_Length
(Statements
(Handler
)) = 1
343 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
344 and then No
(Name
(First
(Statements
(Handler
))))
345 and then (not Others_Present
346 or else Nkind
(First
(Exception_Choices
(Handler
))) =
350 ("useless handler contains only a reraise statement?r?",
354 -- Now analyze the statements of this handler
356 Analyze_Statements
(Statements
(Handler
));
358 -- If a choice was present, we created a special scope for it,
359 -- so this is where we pop that special scope to get rid of it.
361 if Present
(Choice
) then
368 end Analyze_Exception_Handlers
;
370 --------------------------------
371 -- Analyze_Handled_Statements --
372 --------------------------------
374 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
375 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
380 if Present
(Handlers
) then
384 -- We are now going to analyze the statements and then the exception
385 -- handlers. We certainly need to do things in this order to get the
386 -- proper sequential semantics for various warnings.
388 -- However, there is a glitch. When we process raise statements, an
389 -- optimization is to look for local handlers and specialize the code
392 -- In order to detect if a handler is matching, we must have at least
393 -- analyzed the choices in the proper scope so that proper visibility
394 -- analysis is performed. Hence we analyze just the choices first,
395 -- before we analyze the statement sequence.
397 Handler
:= First_Non_Pragma
(Handlers
);
398 while Present
(Handler
) loop
399 Choice
:= First_Non_Pragma
(Exception_Choices
(Handler
));
400 while Present
(Choice
) loop
402 Next_Non_Pragma
(Choice
);
405 Next_Non_Pragma
(Handler
);
408 -- Analyze statements in sequence
410 Analyze_Statements
(Statements
(N
));
412 -- If the current scope is a subprogram, then this is the right place to
413 -- check for hanging useless assignments from the statement sequence of
414 -- the subprogram body.
416 if Is_Subprogram
(Current_Scope
) then
417 Warn_On_Useless_Assignments
(Current_Scope
);
420 -- Deal with handlers or AT END proc
422 if Present
(Handlers
) then
423 Analyze_Exception_Handlers
(Handlers
);
424 elsif Present
(At_End_Proc
(N
)) then
425 Analyze
(At_End_Proc
(N
));
427 end Analyze_Handled_Statements
;
429 ------------------------------
430 -- Analyze_Raise_Expression --
431 ------------------------------
433 procedure Analyze_Raise_Expression
(N
: Node_Id
) is
434 Exception_Id
: constant Node_Id
:= Name
(N
);
435 Exception_Name
: Entity_Id
:= Empty
;
438 Check_SPARK_Restriction
("raise expression is not allowed", N
);
440 -- Check exception restrictions on the original source
442 if Comes_From_Source
(N
) then
443 Check_Restriction
(No_Exceptions
, N
);
446 Analyze
(Exception_Id
);
448 if Is_Entity_Name
(Exception_Id
) then
449 Exception_Name
:= Entity
(Exception_Id
);
452 if No
(Exception_Name
)
453 or else Ekind
(Exception_Name
) /= E_Exception
456 ("exception name expected in raise statement", Exception_Id
);
458 Set_Is_Raised
(Exception_Name
);
461 -- Deal with RAISE WITH case
463 if Present
(Expression
(N
)) then
464 Check_Compiler_Unit
(Expression
(N
));
465 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
468 -- Check obsolescent use of Numeric_Error
470 if Exception_Name
= Standard_Numeric_Error
then
471 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
474 -- Kill last assignment indication
476 Kill_Current_Values
(Last_Assignment_Only
=> True);
478 -- Set type as Any_Type since we have no information at all on the type
480 Set_Etype
(N
, Any_Type
);
481 end Analyze_Raise_Expression
;
483 -----------------------------
484 -- Analyze_Raise_Statement --
485 -----------------------------
487 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
488 Exception_Id
: constant Node_Id
:= Name
(N
);
489 Exception_Name
: Entity_Id
:= Empty
;
494 if Comes_From_Source
(N
) then
495 Check_SPARK_Restriction
("raise statement is not allowed", N
);
498 Check_Unreachable_Code
(N
);
500 -- Check exception restrictions on the original source
502 if Comes_From_Source
(N
) then
503 Check_Restriction
(No_Exceptions
, N
);
506 -- Check for useless assignment to OUT or IN OUT scalar preceding the
507 -- raise. Right now only look at assignment statements, could do more???
509 if Is_List_Member
(N
) then
517 -- Skip past null statements and pragmas
520 and then Nkind_In
(P
, N_Null_Statement
, N_Pragma
)
525 -- See if preceding statement is an assignment
528 and then Nkind
(P
) = N_Assignment_Statement
532 -- Give warning for assignment to scalar formal
534 if Is_Scalar_Type
(Etype
(L
))
535 and then Is_Entity_Name
(L
)
536 and then Is_Formal
(Entity
(L
))
538 -- Do this only for parameters to the current subprogram.
539 -- This avoids some false positives for the nested case.
541 and then Nearest_Dynamic_Scope
(Current_Scope
) =
545 -- Don't give warning if we are covered by an exception
546 -- handler, since this may result in false positives, since
547 -- the handler may handle the exception and return normally.
549 -- First find the enclosing handled sequence of statements
550 -- (note, we could also look for a handler in an outer block
551 -- but currently we don't, and in that case we'll emit the
557 exit when Nkind
(Par
) = N_Handled_Sequence_Of_Statements
;
560 -- See if there is a handler, give message if not
562 if No
(Exception_Handlers
(Par
)) then
564 ("assignment to pass-by-copy formal " &
565 "may have no effect??", P
);
567 ("\RAISE statement may result in abnormal return" &
568 " (RM 6.4.1(17))??", P
);
577 if No
(Exception_Id
) then
579 while not Nkind_In
(P
, N_Exception_Handler
,
588 if Nkind
(P
) /= N_Exception_Handler
then
590 ("reraise statement must appear directly in a handler", N
);
592 -- If a handler has a reraise, it cannot be the target of a local
593 -- raise (goto optimization is impossible), and if the no exception
594 -- propagation restriction is set, this is a violation.
597 Set_Local_Raise_Not_OK
(P
);
599 -- Do not check the restriction if the reraise statement is part
600 -- of the code generated for an AT-END handler. That's because
601 -- if the restriction is actually active, we never generate this
602 -- raise anyway, so the apparent violation is bogus.
604 if not From_At_End
(N
) then
605 Check_Restriction
(No_Exception_Propagation
, N
);
609 -- Normal case with exception id present
612 Analyze
(Exception_Id
);
614 if Is_Entity_Name
(Exception_Id
) then
615 Exception_Name
:= Entity
(Exception_Id
);
618 if No
(Exception_Name
)
619 or else Ekind
(Exception_Name
) /= E_Exception
622 ("exception name expected in raise statement", Exception_Id
);
624 Set_Is_Raised
(Exception_Name
);
627 -- Deal with RAISE WITH case
629 if Present
(Expression
(N
)) then
630 Check_Compiler_Unit
(Expression
(N
));
631 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
635 -- Check obsolescent use of Numeric_Error
637 if Exception_Name
= Standard_Numeric_Error
then
638 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
641 -- Kill last assignment indication
643 Kill_Current_Values
(Last_Assignment_Only
=> True);
644 end Analyze_Raise_Statement
;
646 -----------------------------
647 -- Analyze_Raise_xxx_Error --
648 -----------------------------
650 -- Normally, the Etype is already set (when this node is used within
651 -- an expression, since it is copied from the node which it rewrites).
652 -- If this node is used in a statement context, then we set the type
653 -- Standard_Void_Type. This is used both by Gigi and by the front end
654 -- to distinguish the statement use and the subexpression use.
656 -- The only other required processing is to take care of the Condition
657 -- field if one is present.
659 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
661 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean;
662 -- It often occurs that two identical raise statements are generated in
663 -- succession (for example when dynamic elaboration checks take place on
664 -- separate expressions in a call). If the two statements are identical
665 -- according to the simple criterion that follows, the raise is
666 -- converted into a null statement.
668 ---------------------
669 -- Same_Expression --
670 ---------------------
672 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean is
674 if No
(C1
) and then No
(C2
) then
677 elsif Is_Entity_Name
(C1
) and then Is_Entity_Name
(C2
) then
678 return Entity
(C1
) = Entity
(C2
);
680 elsif Nkind
(C1
) /= Nkind
(C2
) then
683 elsif Nkind
(C1
) in N_Unary_Op
then
684 return Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
686 elsif Nkind
(C1
) in N_Binary_Op
then
687 return Same_Expression
(Left_Opnd
(C1
), Left_Opnd
(C2
))
689 Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
691 elsif Nkind
(C1
) = N_Null
then
699 -- Start of processing for Analyze_Raise_xxx_Error
702 if Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
703 Check_SPARK_Restriction
("raise statement is not allowed", N
);
706 if No
(Etype
(N
)) then
707 Set_Etype
(N
, Standard_Void_Type
);
710 if Present
(Condition
(N
)) then
711 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
714 -- Deal with static cases in obvious manner
716 if Nkind
(Condition
(N
)) = N_Identifier
then
717 if Entity
(Condition
(N
)) = Standard_True
then
718 Set_Condition
(N
, Empty
);
720 elsif Entity
(Condition
(N
)) = Standard_False
then
721 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
725 -- Remove duplicate raise statements. Note that the previous one may
726 -- already have been removed as well.
728 if not Comes_From_Source
(N
)
729 and then Nkind
(N
) /= N_Null_Statement
730 and then Is_List_Member
(N
)
731 and then Present
(Prev
(N
))
732 and then Nkind
(N
) = Nkind
(Original_Node
(Prev
(N
)))
733 and then Same_Expression
734 (Condition
(N
), Condition
(Original_Node
(Prev
(N
))))
736 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
738 end Analyze_Raise_xxx_Error
;