1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
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_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
);
68 Analyze_Aspect_Specifications
(N
, Id
, Aspect_Specifications
(N
));
69 end Analyze_Exception_Declaration
;
71 --------------------------------
72 -- Analyze_Exception_Handlers --
73 --------------------------------
75 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
79 H_Scope
: Entity_Id
:= Empty
;
81 procedure Check_Duplication
(Id
: Node_Id
);
82 -- Iterate through the identifiers in each handler to find duplicates
84 function Others_Present
return Boolean;
85 -- Returns True if others handler is present
87 -----------------------
88 -- Check_Duplication --
89 -----------------------
91 procedure Check_Duplication
(Id
: Node_Id
) is
94 Id_Entity
: Entity_Id
:= Entity
(Id
);
97 if Present
(Renamed_Entity
(Id_Entity
)) then
98 Id_Entity
:= Renamed_Entity
(Id_Entity
);
101 Handler
:= First_Non_Pragma
(L
);
102 while Present
(Handler
) loop
103 Id1
:= First
(Exception_Choices
(Handler
));
104 while Present
(Id1
) loop
106 -- Only check against the exception choices which precede
107 -- Id in the handler, since the ones that follow Id have not
108 -- been analyzed yet and will be checked in a subsequent call.
113 elsif Nkind
(Id1
) /= N_Others_Choice
115 (Id_Entity
= Entity
(Id1
)
116 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
118 if Handler
/= Parent
(Id
) then
119 Error_Msg_Sloc
:= Sloc
(Id1
);
121 ("exception choice duplicates &#", Id
, Id1
);
124 if Ada_Version
= Ada_83
125 and then Comes_From_Source
(Id
)
128 ("(Ada 83): duplicate exception choice&", Id
);
133 Next_Non_Pragma
(Id1
);
138 end Check_Duplication
;
144 function Others_Present
return Boolean is
149 while Present
(H
) loop
150 if Nkind
(H
) /= N_Pragma
151 and then Nkind
(First
(Exception_Choices
(H
))) = N_Others_Choice
162 -- Start of processing for Analyze_Exception_Handlers
165 Handler
:= First
(L
);
166 Check_Restriction
(No_Exceptions
, Handler
);
167 Check_Restriction
(No_Exception_Handlers
, Handler
);
169 -- Kill current remembered values, since we don't know where we were
170 -- when the exception was raised.
174 -- Loop through handlers (which can include pragmas)
176 while Present
(Handler
) loop
178 -- If pragma just analyze it
180 if Nkind
(Handler
) = N_Pragma
then
183 -- Otherwise we have a real exception handler
186 -- Deal with choice parameter. The exception handler is a
187 -- declarative part for the choice parameter, so it constitutes a
188 -- scope for visibility purposes. We create an entity to denote
189 -- the whole exception part, and use it as the scope of all the
190 -- choices, which may even have the same name without conflict.
191 -- This scope plays no other role in expansion or code generation.
193 Choice
:= Choice_Parameter
(Handler
);
195 if Present
(Choice
) then
196 Set_Local_Raise_Not_OK
(Handler
);
198 if Comes_From_Source
(Choice
) then
199 Check_Restriction
(No_Exception_Propagation
, Choice
);
205 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
208 Push_Scope
(H_Scope
);
209 Set_Etype
(H_Scope
, Standard_Void_Type
);
211 -- Set the Finalization Chain entity to Error means that it
212 -- should not be used at that level but the parent one should
215 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
216 -- ??? using Error for this non-error condition is nasty ???
218 Set_Finalization_Chain_Entity
(H_Scope
, Error
);
221 Set_Ekind
(Choice
, E_Variable
);
223 if RTE_Available
(RE_Exception_Occurrence
) then
224 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
227 Generate_Definition
(Choice
);
229 -- Indicate that choice has an initial value, since in effect
230 -- this field is assigned an initial value by the exception.
231 -- We also consider that it is modified in the source.
233 Set_Has_Initial_Value
(Choice
, True);
234 Set_Never_Set_In_Source
(Choice
, False);
237 Id
:= First
(Exception_Choices
(Handler
));
238 while Present
(Id
) loop
239 if Nkind
(Id
) = N_Others_Choice
then
240 if Present
(Next
(Id
))
241 or else Present
(Next
(Handler
))
242 or else Present
(Prev
(Id
))
244 Error_Msg_N
("OTHERS must appear alone and last", Id
);
250 -- In most cases the choice has already been analyzed in
251 -- Analyze_Handled_Statement_Sequence, in order to expand
252 -- local handlers. This advance analysis does not take into
253 -- account the case in which a choice has the same name as
254 -- the choice parameter of the handler, which may hide an
255 -- outer exception. This pathological case appears in ACATS
256 -- B80001_3.adb, and requires an explicit check to verify
257 -- that the id is not hidden.
259 if not Is_Entity_Name
(Id
)
260 or else Ekind
(Entity
(Id
)) /= E_Exception
262 (Nkind
(Id
) = N_Identifier
263 and then Chars
(Id
) = Chars
(Choice
))
265 Error_Msg_N
("exception name expected", Id
);
268 -- Emit a warning at the declaration level when a local
269 -- exception is never raised explicitly.
271 if Warn_On_Redundant_Constructs
272 and then not Is_Raised
(Entity
(Id
))
273 and then Scope
(Entity
(Id
)) = Current_Scope
276 ("?exception & is never raised", Entity
(Id
), Id
);
279 if Present
(Renamed_Entity
(Entity
(Id
))) then
280 if Entity
(Id
) = Standard_Numeric_Error
then
281 Check_Restriction
(No_Obsolescent_Features
, Id
);
283 if Warn_On_Obsolescent_Feature
then
285 ("Numeric_Error is an " &
286 "obsolescent feature (RM J.6(1))?", Id
);
288 ("\use Constraint_Error instead?", Id
);
293 Check_Duplication
(Id
);
295 -- Check for exception declared within generic formal
296 -- package (which is illegal, see RM 11.2(8))
299 Ent
: Entity_Id
:= Entity
(Id
);
303 if Present
(Renamed_Entity
(Ent
)) then
304 Ent
:= Renamed_Entity
(Ent
);
308 while Scop
/= Standard_Standard
309 and then Ekind
(Scop
) = E_Package
311 if Nkind
(Declaration_Node
(Scop
)) =
312 N_Package_Specification
314 Nkind
(Original_Node
(Parent
315 (Declaration_Node
(Scop
)))) =
316 N_Formal_Package_Declaration
319 ("exception& is declared in " &
320 "generic formal package", Id
, Ent
);
322 ("\and therefore cannot appear in " &
323 "handler (RM 11.2(8))", Id
);
326 -- If the exception is declared in an inner
327 -- instance, nothing else to check.
329 elsif Is_Generic_Instance
(Scop
) then
333 Scop
:= Scope
(Scop
);
342 -- Check for redundant handler (has only raise statement) and is
343 -- either an others handler, or is a specific handler when no
344 -- others handler is present.
346 if Warn_On_Redundant_Constructs
347 and then List_Length
(Statements
(Handler
)) = 1
348 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
349 and then No
(Name
(First
(Statements
(Handler
))))
350 and then (not Others_Present
351 or else Nkind
(First
(Exception_Choices
(Handler
))) =
355 ("useless handler contains only a reraise statement?",
359 -- Now analyze the statements of this handler
361 Analyze_Statements
(Statements
(Handler
));
363 -- If a choice was present, we created a special scope for it,
364 -- so this is where we pop that special scope to get rid of it.
366 if Present
(Choice
) then
373 end Analyze_Exception_Handlers
;
375 --------------------------------
376 -- Analyze_Handled_Statements --
377 --------------------------------
379 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
380 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
385 if Present
(Handlers
) then
389 -- We are now going to analyze the statements and then the exception
390 -- handlers. We certainly need to do things in this order to get the
391 -- proper sequential semantics for various warnings.
393 -- However, there is a glitch. When we process raise statements, an
394 -- optimization is to look for local handlers and specialize the code
397 -- In order to detect if a handler is matching, we must have at least
398 -- analyzed the choices in the proper scope so that proper visibility
399 -- analysis is performed. Hence we analyze just the choices first,
400 -- before we analyze the statement sequence.
402 Handler
:= First_Non_Pragma
(Handlers
);
403 while Present
(Handler
) loop
404 Choice
:= First_Non_Pragma
(Exception_Choices
(Handler
));
405 while Present
(Choice
) loop
407 Next_Non_Pragma
(Choice
);
410 Next_Non_Pragma
(Handler
);
413 -- Analyze statements in sequence
415 Analyze_Statements
(Statements
(N
));
417 -- If the current scope is a subprogram, then this is the right place to
418 -- check for hanging useless assignments from the statement sequence of
419 -- the subprogram body.
421 if Is_Subprogram
(Current_Scope
) then
422 Warn_On_Useless_Assignments
(Current_Scope
);
425 -- Deal with handlers or AT END proc
427 if Present
(Handlers
) then
428 Analyze_Exception_Handlers
(Handlers
);
429 elsif Present
(At_End_Proc
(N
)) then
430 Analyze
(At_End_Proc
(N
));
432 end Analyze_Handled_Statements
;
434 -----------------------------
435 -- Analyze_Raise_Statement --
436 -----------------------------
438 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
439 Exception_Id
: constant Node_Id
:= Name
(N
);
440 Exception_Name
: Entity_Id
:= Empty
;
444 Check_Unreachable_Code
(N
);
446 -- Check exception restrictions on the original source
448 if Comes_From_Source
(N
) then
449 Check_Restriction
(No_Exceptions
, N
);
452 -- Check for useless assignment to OUT or IN OUT scalar immediately
453 -- preceding the raise. Right now we only look at assignment statements,
456 if Is_List_Member
(N
) then
465 and then Nkind
(P
) = N_Assignment_Statement
469 if Is_Scalar_Type
(Etype
(L
))
470 and then Is_Entity_Name
(L
)
471 and then Is_Formal
(Entity
(L
))
474 ("?assignment to pass-by-copy formal may have no effect",
477 ("\?RAISE statement may result in abnormal return" &
478 " (RM 6.4.1(17))", P
);
486 if No
(Exception_Id
) then
488 while not Nkind_In
(P
, N_Exception_Handler
,
497 if Nkind
(P
) /= N_Exception_Handler
then
499 ("reraise statement must appear directly in a handler", N
);
501 -- If a handler has a reraise, it cannot be the target of a local
502 -- raise (goto optimization is impossible), and if the no exception
503 -- propagation restriction is set, this is a violation.
506 Set_Local_Raise_Not_OK
(P
);
508 -- Do not check the restriction if the reraise statement is part
509 -- of the code generated for an AT-END handler. That's because
510 -- if the restriction is actually active, we never generate this
511 -- raise anyway, so the apparent violation is bogus.
513 if not From_At_End
(N
) then
514 Check_Restriction
(No_Exception_Propagation
, N
);
518 -- Normal case with exception id present
521 Analyze
(Exception_Id
);
523 if Is_Entity_Name
(Exception_Id
) then
524 Exception_Name
:= Entity
(Exception_Id
);
527 if No
(Exception_Name
)
528 or else Ekind
(Exception_Name
) /= E_Exception
531 ("exception name expected in raise statement", Exception_Id
);
533 Set_Is_Raised
(Exception_Name
);
536 -- Deal with RAISE WITH case
538 if Present
(Expression
(N
)) then
539 Check_Compiler_Unit
(Expression
(N
));
540 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
544 -- Check obsolescent use of Numeric_Error
546 if Exception_Name
= Standard_Numeric_Error
then
547 Check_Restriction
(No_Obsolescent_Features
, Exception_Id
);
550 -- Kill last assignment indication
552 Kill_Current_Values
(Last_Assignment_Only
=> True);
553 end Analyze_Raise_Statement
;
555 -----------------------------
556 -- Analyze_Raise_xxx_Error --
557 -----------------------------
559 -- Normally, the Etype is already set (when this node is used within
560 -- an expression, since it is copied from the node which it rewrites).
561 -- If this node is used in a statement context, then we set the type
562 -- Standard_Void_Type. This is used both by Gigi and by the front end
563 -- to distinguish the statement use and the subexpression use.
565 -- The only other required processing is to take care of the Condition
566 -- field if one is present.
568 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
570 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean;
571 -- It often occurs that two identical raise statements are generated in
572 -- succession (for example when dynamic elaboration checks take place on
573 -- separate expressions in a call). If the two statements are identical
574 -- according to the simple criterion that follows, the raise is
575 -- converted into a null statement.
577 ---------------------
578 -- Same_Expression --
579 ---------------------
581 function Same_Expression
(C1
, C2
: Node_Id
) return Boolean is
583 if No
(C1
) and then No
(C2
) then
586 elsif Is_Entity_Name
(C1
) and then Is_Entity_Name
(C2
) then
587 return Entity
(C1
) = Entity
(C2
);
589 elsif Nkind
(C1
) /= Nkind
(C2
) then
592 elsif Nkind
(C1
) in N_Unary_Op
then
593 return Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
595 elsif Nkind
(C1
) in N_Binary_Op
then
596 return Same_Expression
(Left_Opnd
(C1
), Left_Opnd
(C2
))
597 and then Same_Expression
(Right_Opnd
(C1
), Right_Opnd
(C2
));
599 elsif Nkind
(C1
) = N_Null
then
607 -- Start of processing for Analyze_Raise_xxx_Error
610 if No
(Etype
(N
)) then
611 Set_Etype
(N
, Standard_Void_Type
);
614 if Present
(Condition
(N
)) then
615 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
618 -- Deal with static cases in obvious manner
620 if Nkind
(Condition
(N
)) = N_Identifier
then
621 if Entity
(Condition
(N
)) = Standard_True
then
622 Set_Condition
(N
, Empty
);
624 elsif Entity
(Condition
(N
)) = Standard_False
then
625 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
629 -- Remove duplicate raise statements. Note that the previous one may
630 -- already have been removed as well.
632 if not Comes_From_Source
(N
)
633 and then Nkind
(N
) /= N_Null_Statement
634 and then Is_List_Member
(N
)
635 and then Present
(Prev
(N
))
636 and then Nkind
(N
) = Nkind
(Original_Node
(Prev
(N
)))
637 and then Same_Expression
638 (Condition
(N
), Condition
(Original_Node
(Prev
(N
))))
640 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
642 end Analyze_Raise_xxx_Error
;
644 -----------------------------
645 -- Analyze_Subprogram_Info --
646 -----------------------------
648 procedure Analyze_Subprogram_Info
(N
: Node_Id
) is
650 Set_Etype
(N
, RTE
(RE_Code_Loc
));
651 end Analyze_Subprogram_Info
;