1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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_Ch5
; use Sem_Ch5
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Ch13
; use Sem_Ch13
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sem_Warn
; use Sem_Warn
;
46 with Sinfo
; use Sinfo
;
47 with Stand
; use Stand
;
48 with Uintp
; use Uintp
;
50 package body Sem_Ch11
is
52 -----------------------------------
53 -- Analyze_Exception_Declaration --
54 -----------------------------------
56 procedure Analyze_Exception_Declaration
(N
: Node_Id
) is
57 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
58 PF
: constant Boolean := Is_Pure
(Current_Scope
);
60 Generate_Definition
(Id
);
62 Set_Ekind
(Id
, E_Exception
);
63 Set_Exception_Code
(Id
, Uint_0
);
64 Set_Etype
(Id
, Standard_Exception_Type
);
65 Set_Is_Statically_Allocated
(Id
);
68 if Has_Aspects
(N
) then
69 Analyze_Aspect_Specifications
(N
, Id
);
71 end Analyze_Exception_Declaration
;
73 --------------------------------
74 -- Analyze_Exception_Handlers --
75 --------------------------------
77 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
81 H_Scope
: Entity_Id
:= Empty
;
83 procedure Check_Duplication
(Id
: Node_Id
);
84 -- Iterate through the identifiers in each handler to find duplicates
86 function Others_Present
return Boolean;
87 -- Returns True if others handler is present
89 -----------------------
90 -- Check_Duplication --
91 -----------------------
93 procedure Check_Duplication
(Id
: Node_Id
) is
96 Id_Entity
: Entity_Id
:= Entity
(Id
);
99 if Present
(Renamed_Entity
(Id_Entity
)) then
100 Id_Entity
:= Renamed_Entity
(Id_Entity
);
103 Handler
:= First_Non_Pragma
(L
);
104 while Present
(Handler
) loop
105 Id1
:= First
(Exception_Choices
(Handler
));
106 while Present
(Id1
) loop
108 -- Only check against the exception choices which precede
109 -- Id in the handler, since the ones that follow Id have not
110 -- been analyzed yet and will be checked in a subsequent call.
115 elsif Nkind
(Id1
) /= N_Others_Choice
117 (Id_Entity
= Entity
(Id1
)
118 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
120 if Handler
/= Parent
(Id
) then
121 Error_Msg_Sloc
:= Sloc
(Id1
);
123 ("exception choice duplicates &#", Id
, Id1
);
126 if Ada_Version
= Ada_83
127 and then Comes_From_Source
(Id
)
130 ("(Ada 83): duplicate exception choice&", Id
);
135 Next_Non_Pragma
(Id1
);
140 end Check_Duplication
;
146 function Others_Present
return Boolean is
151 while Present
(H
) loop
152 if Nkind
(H
) /= N_Pragma
153 and then Nkind
(First
(Exception_Choices
(H
))) = N_Others_Choice
164 -- Start of processing for Analyze_Exception_Handlers
167 Handler
:= First
(L
);
168 Check_Restriction
(No_Exceptions
, Handler
);
169 Check_Restriction
(No_Exception_Handlers
, Handler
);
171 -- Kill current remembered values, since we don't know where we were
172 -- when the exception was raised.
176 -- Loop through handlers (which can include pragmas)
178 while Present
(Handler
) loop
180 -- If pragma just analyze it
182 if Nkind
(Handler
) = N_Pragma
then
185 -- Otherwise we have a real exception handler
188 -- Deal with choice parameter. The exception handler is a
189 -- declarative part for the choice parameter, so it constitutes a
190 -- scope for visibility purposes. We create an entity to denote
191 -- the whole exception part, and use it as the scope of all the
192 -- choices, which may even have the same name without conflict.
193 -- This scope plays no other role in expansion or code generation.
195 Choice
:= Choice_Parameter
(Handler
);
197 if Present
(Choice
) then
198 Set_Local_Raise_Not_OK
(Handler
);
200 if Comes_From_Source
(Choice
) then
201 Check_Restriction
(No_Exception_Propagation
, Choice
);
207 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
210 Push_Scope
(H_Scope
);
211 Set_Etype
(H_Scope
, Standard_Void_Type
);
214 Set_Ekind
(Choice
, E_Variable
);
216 if RTE_Available
(RE_Exception_Occurrence
) then
217 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
220 Generate_Definition
(Choice
);
222 -- Indicate that choice has an initial value, since in effect
223 -- this field is assigned an initial value by the exception.
224 -- We also consider that it is modified in the source.
226 Set_Has_Initial_Value
(Choice
, True);
227 Set_Never_Set_In_Source
(Choice
, False);
230 Id
:= First
(Exception_Choices
(Handler
));
231 while Present
(Id
) loop
232 if Nkind
(Id
) = N_Others_Choice
then
233 if Present
(Next
(Id
))
234 or else Present
(Next
(Handler
))
235 or else Present
(Prev
(Id
))
237 Error_Msg_N
("OTHERS must appear alone and last", Id
);
243 -- In most cases the choice has already been analyzed in
244 -- Analyze_Handled_Statement_Sequence, in order to expand
245 -- local handlers. This advance analysis does not take into
246 -- account the case in which a choice has the same name as
247 -- the choice parameter of the handler, which may hide an
248 -- outer exception. This pathological case appears in ACATS
249 -- B80001_3.adb, and requires an explicit check to verify
250 -- that the id is not hidden.
252 if not Is_Entity_Name
(Id
)
253 or else Ekind
(Entity
(Id
)) /= E_Exception
255 (Nkind
(Id
) = N_Identifier
256 and then Chars
(Id
) = Chars
(Choice
))
258 Error_Msg_N
("exception name expected", Id
);
261 -- Emit a warning at the declaration level when a local
262 -- exception is never raised explicitly.
264 if Warn_On_Redundant_Constructs
265 and then not Is_Raised
(Entity
(Id
))
266 and then Scope
(Entity
(Id
)) = Current_Scope
269 ("exception & is never raised?r?", Entity
(Id
), Id
);
272 if Present
(Renamed_Entity
(Entity
(Id
))) then
273 if Entity
(Id
) = Standard_Numeric_Error
then
274 Check_Restriction
(No_Obsolescent_Features
, Id
);
276 if Warn_On_Obsolescent_Feature
then
278 ("Numeric_Error is an " &
279 "obsolescent feature (RM J.6(1))?j?", Id
);
281 ("\use Constraint_Error instead?j?", Id
);
286 Check_Duplication
(Id
);
288 -- Check for exception declared within generic formal
289 -- package (which is illegal, see RM 11.2(8))
292 Ent
: Entity_Id
:= Entity
(Id
);
296 if Present
(Renamed_Entity
(Ent
)) then
297 Ent
:= Renamed_Entity
(Ent
);
301 while Scop
/= Standard_Standard
302 and then Ekind
(Scop
) = E_Package
304 if Nkind
(Declaration_Node
(Scop
)) =
305 N_Package_Specification
307 Nkind
(Original_Node
(Parent
308 (Declaration_Node
(Scop
)))) =
309 N_Formal_Package_Declaration
312 ("exception& is declared in " &
313 "generic formal package", Id
, Ent
);
315 ("\and therefore cannot appear in " &
316 "handler (RM 11.2(8))", Id
);
319 -- If the exception is declared in an inner
320 -- instance, nothing else to check.
322 elsif Is_Generic_Instance
(Scop
) then
326 Scop
:= Scope
(Scop
);
335 -- Check for redundant handler (has only raise statement) and is
336 -- either an others handler, or is a specific handler when no
337 -- others handler is present.
339 if Warn_On_Redundant_Constructs
340 and then List_Length
(Statements
(Handler
)) = 1
341 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
342 and then No
(Name
(First
(Statements
(Handler
))))
343 and then (not Others_Present
344 or else Nkind
(First
(Exception_Choices
(Handler
))) =
348 ("useless handler contains only a reraise statement?r?",
352 -- Now analyze the statements of this handler
354 Analyze_Statements
(Statements
(Handler
));
356 -- If a choice was present, we created a special scope for it,
357 -- so this is where we pop that special scope to get rid of it.
359 if Present
(Choice
) then
366 end Analyze_Exception_Handlers
;
368 --------------------------------
369 -- Analyze_Handled_Statements --
370 --------------------------------
372 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
373 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
378 if Present
(Handlers
) then
382 -- We are now going to analyze the statements and then the exception
383 -- handlers. We certainly need to do things in this order to get the
384 -- proper sequential semantics for various warnings.
386 -- However, there is a glitch. When we process raise statements, an
387 -- optimization is to look for local handlers and specialize the code
390 -- In order to detect if a handler is matching, we must have at least
391 -- analyzed the choices in the proper scope so that proper visibility
392 -- analysis is performed. Hence we analyze just the choices first,
393 -- before we analyze the statement sequence.
395 Handler
:= First_Non_Pragma
(Handlers
);
396 while Present
(Handler
) loop
397 Choice
:= First_Non_Pragma
(Exception_Choices
(Handler
));
398 while Present
(Choice
) loop
400 Next_Non_Pragma
(Choice
);
403 Next_Non_Pragma
(Handler
);
406 -- Analyze statements in sequence
408 Analyze_Statements
(Statements
(N
));
410 -- If the current scope is a subprogram, then this is the right place to
411 -- check for hanging useless assignments from the statement sequence of
412 -- the subprogram body.
414 if Is_Subprogram
(Current_Scope
) then
415 Warn_On_Useless_Assignments
(Current_Scope
);
418 -- Deal with handlers or AT END proc
420 if Present
(Handlers
) then
421 Analyze_Exception_Handlers
(Handlers
);
422 elsif Present
(At_End_Proc
(N
)) then
423 Analyze
(At_End_Proc
(N
));
425 end Analyze_Handled_Statements
;
427 -----------------------------
428 -- Analyze_Raise_Statement --
429 -----------------------------
431 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
432 Exception_Id
: constant Node_Id
:= Name
(N
);
433 Exception_Name
: Entity_Id
:= Empty
;
438 Check_SPARK_Restriction
("raise statement is not allowed", N
);
439 Check_Unreachable_Code
(N
);
441 -- Check exception restrictions on the original source
443 if Comes_From_Source
(N
) then
444 Check_Restriction
(No_Exceptions
, N
);
447 -- Check for useless assignment to OUT or IN OUT scalar preceding the
448 -- raise. Right now only look at assignment statements, could do more???
450 if Is_List_Member
(N
) then
458 -- Skip past null statements and pragmas
461 and then Nkind_In
(P
, N_Null_Statement
, N_Pragma
)
466 -- See if preceding statement is an assignment
469 and then Nkind
(P
) = N_Assignment_Statement
473 -- Give warning for assignment to scalar formal
475 if Is_Scalar_Type
(Etype
(L
))
476 and then Is_Entity_Name
(L
)
477 and then Is_Formal
(Entity
(L
))
479 -- Don't give warning if we are covered by an exception
480 -- handler, since this may result in false positives, since
481 -- the handler may handle the exception and return normally.
483 -- First find the enclosing handled sequence of statements
484 -- (note, we could also look for a handler in an outer block
485 -- but currently we don't, and in that case we'll emit the
491 exit when Nkind
(Par
) = N_Handled_Sequence_Of_Statements
;
494 -- See if there is a handler, give message if not
496 if No
(Exception_Handlers
(Par
)) then
498 ("assignment to pass-by-copy formal " &
499 "may have no effect??", P
);
501 ("\RAISE statement may result in abnormal return" &
502 " (RM 6.4.1(17))??", P
);
511 if No
(Exception_Id
) then
513 while not Nkind_In
(P
, N_Exception_Handler
,
522 if Nkind
(P
) /= N_Exception_Handler
then
524 ("reraise statement must appear directly in a handler", N
);
526 -- If a handler has a reraise, it cannot be the target of a local
527 -- raise (goto optimization is impossible), and if the no exception
528 -- propagation restriction is set, this is a violation.
531 Set_Local_Raise_Not_OK
(P
);
533 -- Do not check the restriction if the reraise statement is part
534 -- of the code generated for an AT-END handler. That's because
535 -- if the restriction is actually active, we never generate this
536 -- raise anyway, so the apparent violation is bogus.
538 if not From_At_End
(N
) then
539 Check_Restriction
(No_Exception_Propagation
, N
);
543 -- Normal case with exception id present
546 Analyze
(Exception_Id
);
548 if Is_Entity_Name
(Exception_Id
) then
549 Exception_Name
:= Entity
(Exception_Id
);
552 if No
(Exception_Name
)
553 or else Ekind
(Exception_Name
) /= E_Exception
556 ("exception name expected in raise statement", Exception_Id
);
558 Set_Is_Raised
(Exception_Name
);
561 -- Deal with RAISE WITH case
563 if Present
(Expression
(N
)) then
564 Check_Compiler_Unit
(Expression
(N
));
565 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
569 -- Check obsolescent use of Numeric_Error
571 if Exception_Name
= Standard_Numeric_Error
then
572 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
575 -- Kill last assignment indication
577 Kill_Current_Values
(Last_Assignment_Only
=> True);
578 end Analyze_Raise_Statement
;
580 -----------------------------
581 -- Analyze_Raise_xxx_Error --
582 -----------------------------
584 -- Normally, the Etype is already set (when this node is used within
585 -- an expression, since it is copied from the node which it rewrites).
586 -- If this node is used in a statement context, then we set the type
587 -- Standard_Void_Type. This is used both by Gigi and by the front end
588 -- to distinguish the statement use and the subexpression use.
590 -- The only other required processing is to take care of the Condition
591 -- field if one is present.
593 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
595 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean;
596 -- It often occurs that two identical raise statements are generated in
597 -- succession (for example when dynamic elaboration checks take place on
598 -- separate expressions in a call). If the two statements are identical
599 -- according to the simple criterion that follows, the raise is
600 -- converted into a null statement.
602 ---------------------
603 -- Same_Expression --
604 ---------------------
606 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean is
608 if No
(C1
) and then No
(C2
) then
611 elsif Is_Entity_Name
(C1
) and then Is_Entity_Name
(C2
) then
612 return Entity
(C1
) = Entity
(C2
);
614 elsif Nkind
(C1
) /= Nkind
(C2
) then
617 elsif Nkind
(C1
) in N_Unary_Op
then
618 return Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
620 elsif Nkind
(C1
) in N_Binary_Op
then
621 return Same_Expression
(Left_Opnd
(C1
), Left_Opnd
(C2
))
623 Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
625 elsif Nkind
(C1
) = N_Null
then
633 -- Start of processing for Analyze_Raise_xxx_Error
636 Check_SPARK_Restriction
("raise statement is not allowed", N
);
638 if No
(Etype
(N
)) then
639 Set_Etype
(N
, Standard_Void_Type
);
642 if Present
(Condition
(N
)) then
643 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
646 -- Deal with static cases in obvious manner
648 if Nkind
(Condition
(N
)) = N_Identifier
then
649 if Entity
(Condition
(N
)) = Standard_True
then
650 Set_Condition
(N
, Empty
);
652 elsif Entity
(Condition
(N
)) = Standard_False
then
653 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
657 -- Remove duplicate raise statements. Note that the previous one may
658 -- already have been removed as well.
660 if not Comes_From_Source
(N
)
661 and then Nkind
(N
) /= N_Null_Statement
662 and then Is_List_Member
(N
)
663 and then Present
(Prev
(N
))
664 and then Nkind
(N
) = Nkind
(Original_Node
(Prev
(N
)))
665 and then Same_Expression
666 (Condition
(N
), Condition
(Original_Node
(Prev
(N
))))
668 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
670 end Analyze_Raise_xxx_Error
;
672 -----------------------------
673 -- Analyze_Subprogram_Info --
674 -----------------------------
676 procedure Analyze_Subprogram_Info
(N
: Node_Id
) is
678 Set_Etype
(N
, RTE
(RE_Code_Loc
));
679 end Analyze_Subprogram_Info
;