1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
;
30 with Ghost
; use Ghost
;
32 with Lib
.Xref
; use Lib
.Xref
;
33 with Namet
; use Namet
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
37 with Restrict
; use Restrict
;
38 with Rident
; use Rident
;
39 with Rtsfind
; use Rtsfind
;
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 Stand
; use Stand
;
51 package body Sem_Ch11
is
53 -----------------------------------
54 -- Analyze_Exception_Declaration --
55 -----------------------------------
57 procedure Analyze_Exception_Declaration
(N
: Node_Id
) is
58 GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
59 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
60 PF
: constant Boolean := Is_Pure
(Current_Scope
);
63 -- The exception declaration may be subject to pragma Ghost with policy
64 -- Ignore. Set the mode now to ensure that any nodes generated during
65 -- analysis and expansion are properly flagged as ignored Ghost.
69 Generate_Definition
(Id
);
71 Set_Ekind
(Id
, E_Exception
);
72 Set_Etype
(Id
, Standard_Exception_Type
);
73 Set_Is_Statically_Allocated
(Id
);
76 -- An exception declared within a Ghost region is automatically Ghost
79 if Ghost_Mode
> None
then
80 Set_Is_Ghost_Entity
(Id
);
83 if Has_Aspects
(N
) then
84 Analyze_Aspect_Specifications
(N
, Id
);
87 -- Restore the original Ghost mode once analysis and expansion have
91 end Analyze_Exception_Declaration
;
93 --------------------------------
94 -- Analyze_Exception_Handlers --
95 --------------------------------
97 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
101 H_Scope
: Entity_Id
:= Empty
;
103 procedure Check_Duplication
(Id
: Node_Id
);
104 -- Iterate through the identifiers in each handler to find duplicates
106 function Others_Present
return Boolean;
107 -- Returns True if others handler is present
109 -----------------------
110 -- Check_Duplication --
111 -----------------------
113 procedure Check_Duplication
(Id
: Node_Id
) is
116 Id_Entity
: Entity_Id
:= Entity
(Id
);
119 if Present
(Renamed_Entity
(Id_Entity
)) then
120 Id_Entity
:= Renamed_Entity
(Id_Entity
);
123 Handler
:= First_Non_Pragma
(L
);
124 while Present
(Handler
) loop
125 Id1
:= First
(Exception_Choices
(Handler
));
126 while Present
(Id1
) loop
128 -- Only check against the exception choices which precede
129 -- Id in the handler, since the ones that follow Id have not
130 -- been analyzed yet and will be checked in a subsequent call.
135 elsif Nkind
(Id1
) /= N_Others_Choice
137 (Id_Entity
= Entity
(Id1
)
138 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
140 if Handler
/= Parent
(Id
) then
141 Error_Msg_Sloc
:= Sloc
(Id1
);
142 Error_Msg_NE
("exception choice duplicates &#", Id
, Id1
);
145 if Ada_Version
= Ada_83
146 and then Comes_From_Source
(Id
)
149 ("(Ada 83): duplicate exception choice&", Id
);
154 Next_Non_Pragma
(Id1
);
159 end Check_Duplication
;
165 function Others_Present
return Boolean is
170 while Present
(H
) loop
171 if Nkind
(H
) /= N_Pragma
172 and then Nkind
(First
(Exception_Choices
(H
))) = N_Others_Choice
183 -- Start of processing for Analyze_Exception_Handlers
186 Handler
:= First
(L
);
187 Check_Restriction
(No_Exceptions
, Handler
);
188 Check_Restriction
(No_Exception_Handlers
, Handler
);
190 -- Kill current remembered values, since we don't know where we were
191 -- when the exception was raised.
195 -- Loop through handlers (which can include pragmas)
197 while Present
(Handler
) loop
199 -- If pragma just analyze it
201 if Nkind
(Handler
) = N_Pragma
then
204 -- Otherwise we have a real exception handler
207 -- Deal with choice parameter. The exception handler is a
208 -- declarative part for the choice parameter, so it constitutes a
209 -- scope for visibility purposes. We create an entity to denote
210 -- the whole exception part, and use it as the scope of all the
211 -- choices, which may even have the same name without conflict.
212 -- This scope plays no other role in expansion or code generation.
214 Choice
:= Choice_Parameter
(Handler
);
216 if Present
(Choice
) then
217 Set_Local_Raise_Not_OK
(Handler
);
219 if Comes_From_Source
(Choice
) then
220 Check_Restriction
(No_Exception_Propagation
, Choice
);
221 Set_Debug_Info_Needed
(Choice
);
227 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
230 Push_Scope
(H_Scope
);
231 Set_Etype
(H_Scope
, Standard_Void_Type
);
234 Set_Ekind
(Choice
, E_Variable
);
236 if RTE_Available
(RE_Exception_Occurrence
) then
237 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
240 Generate_Definition
(Choice
);
242 -- Indicate that choice has an initial value, since in effect
243 -- this field is assigned an initial value by the exception.
244 -- We also consider that it is modified in the source.
246 Set_Has_Initial_Value
(Choice
, True);
247 Set_Never_Set_In_Source
(Choice
, False);
250 Id
:= First
(Exception_Choices
(Handler
));
251 while Present
(Id
) loop
252 if Nkind
(Id
) = N_Others_Choice
then
253 if Present
(Next
(Id
))
254 or else Present
(Next
(Handler
))
255 or else Present
(Prev
(Id
))
257 Error_Msg_N
("OTHERS must appear alone and last", Id
);
263 -- In most cases the choice has already been analyzed in
264 -- Analyze_Handled_Statement_Sequence, in order to expand
265 -- local handlers. This advance analysis does not take into
266 -- account the case in which a choice has the same name as
267 -- the choice parameter of the handler, which may hide an
268 -- outer exception. This pathological case appears in ACATS
269 -- B80001_3.adb, and requires an explicit check to verify
270 -- that the id is not hidden.
272 if not Is_Entity_Name
(Id
)
273 or else Ekind
(Entity
(Id
)) /= E_Exception
275 (Nkind
(Id
) = N_Identifier
276 and then Chars
(Id
) = Chars
(Choice
))
278 Error_Msg_N
("exception name expected", Id
);
281 -- Emit a warning at the declaration level when a local
282 -- exception is never raised explicitly.
284 if Warn_On_Redundant_Constructs
285 and then not Is_Raised
(Entity
(Id
))
286 and then Scope
(Entity
(Id
)) = Current_Scope
289 ("exception & is never raised?r?", Entity
(Id
), Id
);
292 if Present
(Renamed_Entity
(Entity
(Id
))) then
293 if Entity
(Id
) = Standard_Numeric_Error
then
294 Check_Restriction
(No_Obsolescent_Features
, Id
);
296 if Warn_On_Obsolescent_Feature
then
298 ("Numeric_Error is an " &
299 "obsolescent feature (RM J.6(1))?j?", Id
);
301 ("\use Constraint_Error instead?j?", Id
);
306 Check_Duplication
(Id
);
308 -- Check for exception declared within generic formal
309 -- package (which is illegal, see RM 11.2(8))
312 Ent
: Entity_Id
:= Entity
(Id
);
316 if Present
(Renamed_Entity
(Ent
)) then
317 Ent
:= Renamed_Entity
(Ent
);
321 while Scop
/= Standard_Standard
322 and then Ekind
(Scop
) = E_Package
324 if Nkind
(Declaration_Node
(Scop
)) =
325 N_Package_Specification
327 Nkind
(Original_Node
(Parent
328 (Declaration_Node
(Scop
)))) =
329 N_Formal_Package_Declaration
332 ("exception& is declared in " &
333 "generic formal package", Id
, Ent
);
335 ("\and therefore cannot appear in " &
336 "handler (RM 11.2(8))", Id
);
339 -- If the exception is declared in an inner
340 -- instance, nothing else to check.
342 elsif Is_Generic_Instance
(Scop
) then
346 Scop
:= Scope
(Scop
);
355 -- Check for redundant handler (has only raise statement) and is
356 -- either an others handler, or is a specific handler when no
357 -- others handler is present.
359 if Warn_On_Redundant_Constructs
360 and then List_Length
(Statements
(Handler
)) = 1
361 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
362 and then No
(Name
(First
(Statements
(Handler
))))
363 and then (not Others_Present
364 or else Nkind
(First
(Exception_Choices
(Handler
))) =
368 ("useless handler contains only a reraise statement?r?",
372 -- Now analyze the statements of this handler
374 Analyze_Statements
(Statements
(Handler
));
376 -- If a choice was present, we created a special scope for it,
377 -- so this is where we pop that special scope to get rid of it.
379 if Present
(Choice
) then
386 end Analyze_Exception_Handlers
;
388 --------------------------------
389 -- Analyze_Handled_Statements --
390 --------------------------------
392 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
393 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
398 if Present
(Handlers
) then
402 -- We are now going to analyze the statements and then the exception
403 -- handlers. We certainly need to do things in this order to get the
404 -- proper sequential semantics for various warnings.
406 -- However, there is a glitch. When we process raise statements, an
407 -- optimization is to look for local handlers and specialize the code
410 -- In order to detect if a handler is matching, we must have at least
411 -- analyzed the choices in the proper scope so that proper visibility
412 -- analysis is performed. Hence we analyze just the choices first,
413 -- before we analyze the statement sequence.
415 Handler
:= First_Non_Pragma
(Handlers
);
416 while Present
(Handler
) loop
417 Choice
:= First_Non_Pragma
(Exception_Choices
(Handler
));
418 while Present
(Choice
) loop
420 Next_Non_Pragma
(Choice
);
423 Next_Non_Pragma
(Handler
);
426 -- Analyze statements in sequence
428 Analyze_Statements
(Statements
(N
));
430 -- If the current scope is a subprogram, then this is the right place to
431 -- check for hanging useless assignments from the statement sequence of
432 -- the subprogram body.
434 if Is_Subprogram
(Current_Scope
) then
435 Warn_On_Useless_Assignments
(Current_Scope
);
438 -- Deal with handlers or AT END proc
440 if Present
(Handlers
) then
441 Analyze_Exception_Handlers
(Handlers
);
442 elsif Present
(At_End_Proc
(N
)) then
443 Analyze
(At_End_Proc
(N
));
445 end Analyze_Handled_Statements
;
447 ------------------------------
448 -- Analyze_Raise_Expression --
449 ------------------------------
451 procedure Analyze_Raise_Expression
(N
: Node_Id
) is
452 Exception_Id
: constant Node_Id
:= Name
(N
);
453 Exception_Name
: Entity_Id
:= Empty
;
456 if Comes_From_Source
(N
) then
457 Check_Compiler_Unit
("raise expression", N
);
460 Check_SPARK_05_Restriction
("raise expression is not allowed", N
);
462 -- Check exception restrictions on the original source
464 if Comes_From_Source
(N
) then
465 Check_Restriction
(No_Exceptions
, N
);
468 Analyze
(Exception_Id
);
470 if Is_Entity_Name
(Exception_Id
) then
471 Exception_Name
:= Entity
(Exception_Id
);
474 if No
(Exception_Name
)
475 or else Ekind
(Exception_Name
) /= E_Exception
478 ("exception name expected in raise statement", Exception_Id
);
480 Set_Is_Raised
(Exception_Name
);
483 -- Deal with RAISE WITH case
485 if Present
(Expression
(N
)) then
486 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
489 -- Check obsolescent use of Numeric_Error
491 if Exception_Name
= Standard_Numeric_Error
then
492 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
495 -- Kill last assignment indication
497 Kill_Current_Values
(Last_Assignment_Only
=> True);
499 -- Raise_Type is compatible with all other types so that the raise
500 -- expression is legal in any expression context. It will be eventually
501 -- replaced by the concrete type imposed by the context.
503 Set_Etype
(N
, Raise_Type
);
504 end Analyze_Raise_Expression
;
506 -----------------------------
507 -- Analyze_Raise_Statement --
508 -----------------------------
510 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
511 Exception_Id
: constant Node_Id
:= Name
(N
);
512 Exception_Name
: Entity_Id
:= Empty
;
517 if Comes_From_Source
(N
) then
518 Check_SPARK_05_Restriction
("raise statement is not allowed", N
);
521 Check_Unreachable_Code
(N
);
523 -- Check exception restrictions on the original source
525 if Comes_From_Source
(N
) then
526 Check_Restriction
(No_Exceptions
, N
);
529 -- Check for useless assignment to OUT or IN OUT scalar preceding the
530 -- raise. Right now only look at assignment statements, could do more???
532 if Is_List_Member
(N
) then
540 -- Skip past null statements and pragmas
543 and then Nkind_In
(P
, N_Null_Statement
, N_Pragma
)
548 -- See if preceding statement is an assignment
550 if Present
(P
) and then Nkind
(P
) = N_Assignment_Statement
then
553 -- Give warning for assignment to scalar formal
555 if Is_Scalar_Type
(Etype
(L
))
556 and then Is_Entity_Name
(L
)
557 and then Is_Formal
(Entity
(L
))
559 -- Do this only for parameters to the current subprogram.
560 -- This avoids some false positives for the nested case.
562 and then Nearest_Dynamic_Scope
(Current_Scope
) =
566 -- Don't give warning if we are covered by an exception
567 -- handler, since this may result in false positives, since
568 -- the handler may handle the exception and return normally.
570 -- First find the enclosing handled sequence of statements
571 -- (note, we could also look for a handler in an outer block
572 -- but currently we don't, and in that case we'll emit the
578 exit when Nkind
(Par
) = N_Handled_Sequence_Of_Statements
;
581 -- See if there is a handler, give message if not
583 if No
(Exception_Handlers
(Par
)) then
585 ("assignment to pass-by-copy formal "
586 & "may have no effect??", P
);
588 ("\RAISE statement may result in abnormal return "
589 & "(RM 6.4.1(17))??", P
);
598 if No
(Exception_Id
) then
600 while not Nkind_In
(P
, N_Exception_Handler
,
609 if Nkind
(P
) /= N_Exception_Handler
then
611 ("reraise statement must appear directly in a handler", N
);
613 -- If a handler has a reraise, it cannot be the target of a local
614 -- raise (goto optimization is impossible), and if the no exception
615 -- propagation restriction is set, this is a violation.
618 Set_Local_Raise_Not_OK
(P
);
620 -- Do not check the restriction if the reraise statement is part
621 -- of the code generated for an AT-END handler. That's because
622 -- if the restriction is actually active, we never generate this
623 -- raise anyway, so the apparent violation is bogus.
625 if not From_At_End
(N
) then
626 Check_Restriction
(No_Exception_Propagation
, N
);
630 -- Normal case with exception id present
633 Analyze
(Exception_Id
);
635 if Is_Entity_Name
(Exception_Id
) then
636 Exception_Name
:= Entity
(Exception_Id
);
639 if No
(Exception_Name
)
640 or else Ekind
(Exception_Name
) /= E_Exception
643 ("exception name expected in raise statement", Exception_Id
);
645 Set_Is_Raised
(Exception_Name
);
648 -- Deal with RAISE WITH case
650 if Present
(Expression
(N
)) then
651 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
655 -- Check obsolescent use of Numeric_Error
657 if Exception_Name
= Standard_Numeric_Error
then
658 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
661 -- Kill last assignment indication
663 Kill_Current_Values
(Last_Assignment_Only
=> True);
664 end Analyze_Raise_Statement
;
666 -----------------------------
667 -- Analyze_Raise_xxx_Error --
668 -----------------------------
670 -- Normally, the Etype is already set (when this node is used within
671 -- an expression, since it is copied from the node which it rewrites).
672 -- If this node is used in a statement context, then we set the type
673 -- Standard_Void_Type. This is used both by Gigi and by the front end
674 -- to distinguish the statement use and the subexpression use.
676 -- The only other required processing is to take care of the Condition
677 -- field if one is present.
679 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
681 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean;
682 -- It often occurs that two identical raise statements are generated in
683 -- succession (for example when dynamic elaboration checks take place on
684 -- separate expressions in a call). If the two statements are identical
685 -- according to the simple criterion that follows, the raise is
686 -- converted into a null statement.
688 ---------------------
689 -- Same_Expression --
690 ---------------------
692 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean is
694 if No
(C1
) and then No
(C2
) then
697 elsif Is_Entity_Name
(C1
) and then Is_Entity_Name
(C2
) then
698 return Entity
(C1
) = Entity
(C2
);
700 elsif Nkind
(C1
) /= Nkind
(C2
) then
703 elsif Nkind
(C1
) in N_Unary_Op
then
704 return Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
706 elsif Nkind
(C1
) in N_Binary_Op
then
707 return Same_Expression
(Left_Opnd
(C1
), Left_Opnd
(C2
))
709 Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
711 elsif Nkind
(C1
) = N_Null
then
719 -- Start of processing for Analyze_Raise_xxx_Error
722 if Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
723 Check_SPARK_05_Restriction
("raise statement is not allowed", N
);
726 if No
(Etype
(N
)) then
727 Set_Etype
(N
, Standard_Void_Type
);
730 if Present
(Condition
(N
)) then
731 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
734 -- Deal with static cases in obvious manner
736 if Nkind
(Condition
(N
)) = N_Identifier
then
737 if Entity
(Condition
(N
)) = Standard_True
then
738 Set_Condition
(N
, Empty
);
740 elsif Entity
(Condition
(N
)) = Standard_False
then
741 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
745 -- Remove duplicate raise statements. Note that the previous one may
746 -- already have been removed as well.
748 if not Comes_From_Source
(N
)
749 and then Nkind
(N
) /= N_Null_Statement
750 and then Is_List_Member
(N
)
751 and then Present
(Prev
(N
))
752 and then Nkind
(N
) = Nkind
(Original_Node
(Prev
(N
)))
753 and then Same_Expression
754 (Condition
(N
), Condition
(Original_Node
(Prev
(N
))))
756 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
758 end Analyze_Raise_xxx_Error
;