1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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_Res
; use Sem_Res
;
43 with Sem_Util
; use Sem_Util
;
44 with Sem_Warn
; use Sem_Warn
;
45 with Sinfo
; use Sinfo
;
46 with Stand
; use Stand
;
47 with Uintp
; use Uintp
;
49 package body Sem_Ch11
is
51 -----------------------------------
52 -- Analyze_Exception_Declaration --
53 -----------------------------------
55 procedure Analyze_Exception_Declaration
(N
: Node_Id
) is
56 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
57 PF
: constant Boolean := Is_Pure
(Current_Scope
);
59 Generate_Definition
(Id
);
61 Set_Ekind
(Id
, E_Exception
);
62 Set_Exception_Code
(Id
, Uint_0
);
63 Set_Etype
(Id
, Standard_Exception_Type
);
64 Set_Is_Statically_Allocated
(Id
);
66 end Analyze_Exception_Declaration
;
68 --------------------------------
69 -- Analyze_Exception_Handlers --
70 --------------------------------
72 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
76 H_Scope
: Entity_Id
:= Empty
;
78 procedure Check_Duplication
(Id
: Node_Id
);
79 -- Iterate through the identifiers in each handler to find duplicates
81 function Others_Present
return Boolean;
82 -- Returns True if others handler is present
84 -----------------------
85 -- Check_Duplication --
86 -----------------------
88 procedure Check_Duplication
(Id
: Node_Id
) is
91 Id_Entity
: Entity_Id
:= Entity
(Id
);
94 if Present
(Renamed_Entity
(Id_Entity
)) then
95 Id_Entity
:= Renamed_Entity
(Id_Entity
);
98 Handler
:= First_Non_Pragma
(L
);
99 while Present
(Handler
) loop
100 Id1
:= First
(Exception_Choices
(Handler
));
101 while Present
(Id1
) loop
103 -- Only check against the exception choices which precede
104 -- Id in the handler, since the ones that follow Id have not
105 -- been analyzed yet and will be checked in a subsequent call.
110 elsif Nkind
(Id1
) /= N_Others_Choice
112 (Id_Entity
= Entity
(Id1
)
113 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
115 if Handler
/= Parent
(Id
) then
116 Error_Msg_Sloc
:= Sloc
(Id1
);
118 ("exception choice duplicates &#", Id
, Id1
);
121 if Ada_Version
= Ada_83
122 and then Comes_From_Source
(Id
)
125 ("(Ada 83): duplicate exception choice&", Id
);
130 Next_Non_Pragma
(Id1
);
135 end Check_Duplication
;
141 function Others_Present
return Boolean is
146 while Present
(H
) loop
147 if Nkind
(H
) /= N_Pragma
148 and then Nkind
(First
(Exception_Choices
(H
))) = N_Others_Choice
159 -- Start processing for Analyze_Exception_Handlers
162 Handler
:= First
(L
);
163 Check_Restriction
(No_Exceptions
, Handler
);
164 Check_Restriction
(No_Exception_Handlers
, Handler
);
166 -- Kill current remembered values, since we don't know where we were
167 -- when the exception was raised.
171 -- Loop through handlers (which can include pragmas)
173 while Present
(Handler
) loop
175 -- If pragma just analyze it
177 if Nkind
(Handler
) = N_Pragma
then
180 -- Otherwise we have a real exception handler
183 -- Deal with choice parameter. The exception handler is a
184 -- declarative part for the choice parameter, so it constitutes a
185 -- scope for visibility purposes. We create an entity to denote
186 -- the whole exception part, and use it as the scope of all the
187 -- choices, which may even have the same name without conflict.
188 -- This scope plays no other role in expansion or or code
191 Choice
:= Choice_Parameter
(Handler
);
193 if Present
(Choice
) then
194 Set_Local_Raise_Not_OK
(Handler
);
196 if Comes_From_Source
(Choice
) then
197 Check_Restriction
(No_Exception_Propagation
, Choice
);
203 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
206 Push_Scope
(H_Scope
);
207 Set_Etype
(H_Scope
, Standard_Void_Type
);
209 -- Set the Finalization Chain entity to Error means that it
210 -- should not be used at that level but the parent one should
213 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
214 -- ??? using Error for this non-error condition is nasty ???
216 Set_Finalization_Chain_Entity
(H_Scope
, Error
);
219 Set_Ekind
(Choice
, E_Variable
);
221 if RTE_Available
(RE_Exception_Occurrence
) then
222 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
225 Generate_Definition
(Choice
);
227 -- Indicate that choice has an initial value, since in effect
228 -- this field is assigned an initial value by the exception.
229 -- We also consider that it is modified in the source.
231 Set_Has_Initial_Value
(Choice
, True);
232 Set_Never_Set_In_Source
(Choice
, False);
235 Id
:= First
(Exception_Choices
(Handler
));
236 while Present
(Id
) loop
237 if Nkind
(Id
) = N_Others_Choice
then
238 if Present
(Next
(Id
))
239 or else Present
(Next
(Handler
))
240 or else Present
(Prev
(Id
))
242 Error_Msg_N
("OTHERS must appear alone and last", Id
);
248 -- In most cases the choice has already been analyzed in
249 -- Analyze_Handled_Statement_Sequence, in order to expand
250 -- local handlers. This advance analysis does not take into
251 -- account the case in which a choice has the same name as
252 -- the choice parameter of the handler, which may hide an
253 -- outer exception. This pathological case appears in ACATS
254 -- B80001_3.adb, and requires an explicit check to verify
255 -- that the id is not hidden.
257 if not Is_Entity_Name
(Id
)
258 or else Ekind
(Entity
(Id
)) /= E_Exception
260 (Nkind
(Id
) = N_Identifier
261 and then Chars
(Id
) = Chars
(Choice
))
263 Error_Msg_N
("exception name expected", Id
);
266 -- Emit a warning at the declaration level when a local
267 -- exception is never raised explicitly.
269 if Warn_On_Redundant_Constructs
270 and then not Is_Raised
(Entity
(Id
))
271 and then Scope
(Entity
(Id
)) = Current_Scope
274 ("?exception & is never raised", Entity
(Id
), Id
);
277 if Present
(Renamed_Entity
(Entity
(Id
))) then
278 if Entity
(Id
) = Standard_Numeric_Error
then
279 Check_Restriction
(No_Obsolescent_Features
, Id
);
281 if Warn_On_Obsolescent_Feature
then
283 ("Numeric_Error is an " &
284 "obsolescent feature (RM J.6(1))?", Id
);
286 ("\use Constraint_Error instead?", Id
);
291 Check_Duplication
(Id
);
293 -- Check for exception declared within generic formal
294 -- package (which is illegal, see RM 11.2(8))
297 Ent
: Entity_Id
:= Entity
(Id
);
301 if Present
(Renamed_Entity
(Ent
)) then
302 Ent
:= Renamed_Entity
(Ent
);
306 while Scop
/= Standard_Standard
307 and then Ekind
(Scop
) = E_Package
309 if Nkind
(Declaration_Node
(Scop
)) =
310 N_Package_Specification
312 Nkind
(Original_Node
(Parent
313 (Declaration_Node
(Scop
)))) =
314 N_Formal_Package_Declaration
317 ("exception& is declared in " &
318 "generic formal package", Id
, Ent
);
320 ("\and therefore cannot appear in " &
321 "handler (RM 11.2(8))", Id
);
324 -- If the exception is declared in an inner
325 -- instance, nothing else to check.
327 elsif Is_Generic_Instance
(Scop
) then
331 Scop
:= Scope
(Scop
);
340 -- Check for redundant handler (has only raise statement) and is
341 -- either an others handler, or is a specific handler when no
342 -- others handler is present.
344 if Warn_On_Redundant_Constructs
345 and then List_Length
(Statements
(Handler
)) = 1
346 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
347 and then No
(Name
(First
(Statements
(Handler
))))
348 and then (not Others_Present
349 or else Nkind
(First
(Exception_Choices
(Handler
))) =
353 ("useless handler contains only a reraise statement?",
357 -- Now analyze the statements of this handler
359 Analyze_Statements
(Statements
(Handler
));
361 -- If a choice was present, we created a special scope for it,
362 -- so this is where we pop that special scope to get rid of it.
364 if Present
(Choice
) then
371 end Analyze_Exception_Handlers
;
373 --------------------------------
374 -- Analyze_Handled_Statements --
375 --------------------------------
377 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
378 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
383 if Present
(Handlers
) then
387 -- We are now going to analyze the statements and then the exception
388 -- handlers. We certainly need to do things in this order to get the
389 -- proper sequential semantics for various warnings.
391 -- However, there is a glitch. When we process raise statements, an
392 -- optimization is to look for local handlers and specialize the code
395 -- In order to detect if a handler is matching, we must have at least
396 -- analyzed the choices in the proper scope so that proper visibility
397 -- analysis is performed. Hence we analyze just the choices first,
398 -- before we analyze the statement sequence.
400 Handler
:= First_Non_Pragma
(Handlers
);
401 while Present
(Handler
) loop
402 Choice
:= First_Non_Pragma
(Exception_Choices
(Handler
));
403 while Present
(Choice
) loop
405 Next_Non_Pragma
(Choice
);
408 Next_Non_Pragma
(Handler
);
411 -- Analyze statements in sequence
413 Analyze_Statements
(Statements
(N
));
415 -- If the current scope is a subprogram, then this is the right place to
416 -- check for hanging useless assignments from the statement sequence of
417 -- the subprogram body.
419 if Is_Subprogram
(Current_Scope
) then
420 Warn_On_Useless_Assignments
(Current_Scope
);
423 -- Deal with handlers or AT END proc
425 if Present
(Handlers
) then
426 Analyze_Exception_Handlers
(Handlers
);
427 elsif Present
(At_End_Proc
(N
)) then
428 Analyze
(At_End_Proc
(N
));
430 end Analyze_Handled_Statements
;
432 -----------------------------
433 -- Analyze_Raise_Statement --
434 -----------------------------
436 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
437 Exception_Id
: constant Node_Id
:= Name
(N
);
438 Exception_Name
: Entity_Id
:= Empty
;
442 Check_Unreachable_Code
(N
);
444 -- Check exception restrictions on the original source
446 if Comes_From_Source
(N
) then
447 Check_Restriction
(No_Exceptions
, N
);
450 -- Check for useless assignment to OUT or IN OUT scalar immediately
451 -- preceding the raise. Right now we only look at assignment statements,
454 if Is_List_Member
(N
) then
463 and then Nkind
(P
) = N_Assignment_Statement
467 if Is_Scalar_Type
(Etype
(L
))
468 and then Is_Entity_Name
(L
)
469 and then Is_Formal
(Entity
(L
))
472 ("?assignment to pass-by-copy formal may have no effect",
475 ("\?RAISE statement may result in abnormal return" &
476 " (RM 6.4.1(17))", P
);
484 if No
(Exception_Id
) then
486 while not Nkind_In
(P
, N_Exception_Handler
,
495 if Nkind
(P
) /= N_Exception_Handler
then
497 ("reraise statement must appear directly in a handler", N
);
499 -- If a handler has a reraise, it cannot be the target of a local
500 -- raise (goto optimization is impossible), and if the no exception
501 -- propagation restriction is set, this is a violation.
504 Set_Local_Raise_Not_OK
(P
);
506 -- Do not check the restriction if the reraise statement is part
507 -- of the code generated for an AT-END handler. That's because
508 -- if the restriction is actually active, we never generate this
509 -- raise anyway, so the apparent violation is bogus.
511 if not From_At_End
(N
) then
512 Check_Restriction
(No_Exception_Propagation
, N
);
516 -- Normal case with exception id present
519 Analyze
(Exception_Id
);
521 if Is_Entity_Name
(Exception_Id
) then
522 Exception_Name
:= Entity
(Exception_Id
);
525 if No
(Exception_Name
)
526 or else Ekind
(Exception_Name
) /= E_Exception
529 ("exception name expected in raise statement", Exception_Id
);
531 Set_Is_Raised
(Exception_Name
);
534 -- Deal with RAISE WITH case
536 if Present
(Expression
(N
)) then
537 Check_Compiler_Unit
(Expression
(N
));
538 Analyze_And_Resolve
(Expression
(N
), Standard_String
);
542 Kill_Current_Values
(Last_Assignment_Only
=> True);
543 end Analyze_Raise_Statement
;
545 -----------------------------
546 -- Analyze_Raise_xxx_Error --
547 -----------------------------
549 -- Normally, the Etype is already set (when this node is used within
550 -- an expression, since it is copied from the node which it rewrites).
551 -- If this node is used in a statement context, then we set the type
552 -- Standard_Void_Type. This is used both by Gigi and by the front end
553 -- to distinguish the statement use and the subexpression use.
555 -- The only other required processing is to take care of the Condition
556 -- field if one is present.
558 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
560 if No
(Etype
(N
)) then
561 Set_Etype
(N
, Standard_Void_Type
);
564 if Present
(Condition
(N
)) then
565 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
568 -- Deal with static cases in obvious manner
570 if Nkind
(Condition
(N
)) = N_Identifier
then
571 if Entity
(Condition
(N
)) = Standard_True
then
572 Set_Condition
(N
, Empty
);
574 elsif Entity
(Condition
(N
)) = Standard_False
then
575 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
578 end Analyze_Raise_xxx_Error
;
580 -----------------------------
581 -- Analyze_Subprogram_Info --
582 -----------------------------
584 procedure Analyze_Subprogram_Info
(N
: Node_Id
) is
586 Set_Etype
(N
, RTE
(RE_Code_Loc
));
587 end Analyze_Subprogram_Info
;