1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
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 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 Sinfo
; use Sinfo
;
45 with Stand
; use Stand
;
46 with Uintp
; use Uintp
;
48 package body Sem_Ch11
is
50 -----------------------------------
51 -- Analyze_Exception_Declaration --
52 -----------------------------------
54 procedure Analyze_Exception_Declaration
(N
: Node_Id
) is
55 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
56 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
);
65 Set_Is_Statically_Allocated
(Id
);
67 end Analyze_Exception_Declaration
;
69 --------------------------------
70 -- Analyze_Exception_Handlers --
71 --------------------------------
73 procedure Analyze_Exception_Handlers
(L
: List_Id
) is
77 H_Scope
: Entity_Id
:= Empty
;
79 procedure Check_Duplication
(Id
: Node_Id
);
80 -- Iterate through the identifiers in each handler to find duplicates
82 function Others_Present
return Boolean;
83 -- Returns True if others handler is present
85 -----------------------
86 -- Check_Duplication --
87 -----------------------
89 procedure Check_Duplication
(Id
: Node_Id
) is
92 Id_Entity
: Entity_Id
:= Entity
(Id
);
95 if Present
(Renamed_Entity
(Id_Entity
)) then
96 Id_Entity
:= Renamed_Entity
(Id_Entity
);
99 Handler
:= First_Non_Pragma
(L
);
100 while Present
(Handler
) loop
101 Id1
:= First
(Exception_Choices
(Handler
));
103 while Present
(Id1
) loop
105 -- Only check against the exception choices which precede
106 -- Id in the handler, since the ones that follow Id have not
107 -- been analyzed yet and will be checked in a subsequent call.
112 elsif Nkind
(Id1
) /= N_Others_Choice
114 (Id_Entity
= Entity
(Id1
)
115 or else (Id_Entity
= Renamed_Entity
(Entity
(Id1
))))
117 if Handler
/= Parent
(Id
) then
118 Error_Msg_Sloc
:= Sloc
(Id1
);
120 ("exception choice duplicates &#", Id
, Id1
);
123 if Ada_83
and then Comes_From_Source
(Id
) then
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
184 -- a declarative part for it, so it constitutes a scope
185 -- for visibility purposes. We create an entity to denote
186 -- the whole exception part, and use it as the scope of all
187 -- the choices, which may even have the same name without
188 -- conflict. This scope plays no other role in expansion or
189 -- or code generation.
191 Choice
:= Choice_Parameter
(Handler
);
193 if Present
(Choice
) then
195 H_Scope
:= New_Internal_Entity
196 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
200 Set_Etype
(H_Scope
, Standard_Void_Type
);
202 -- Set the Finalization Chain entity to Error means that it
203 -- should not be used at that level but the parent one
204 -- should be used instead.
206 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
207 -- ??? using Error for this non-error condition is nasty ???
209 Set_Finalization_Chain_Entity
(H_Scope
, Error
);
212 Set_Ekind
(Choice
, E_Variable
);
213 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
214 Generate_Definition
(Choice
);
216 -- Set source assigned flag, since in effect this field
217 -- is always assigned an initial value by the exception.
219 Set_Never_Set_In_Source
(Choice
, False);
222 Id
:= First
(Exception_Choices
(Handler
));
223 while Present
(Id
) loop
224 if Nkind
(Id
) = N_Others_Choice
then
225 if Present
(Next
(Id
))
226 or else Present
(Next
(Handler
))
227 or else Present
(Prev
(Id
))
229 Error_Msg_N
("OTHERS must appear alone and last", Id
);
235 if not Is_Entity_Name
(Id
)
236 or else Ekind
(Entity
(Id
)) /= E_Exception
238 Error_Msg_N
("exception name expected", Id
);
241 if Present
(Renamed_Entity
(Entity
(Id
))) then
242 if Entity
(Id
) = Standard_Numeric_Error
243 and then Warn_On_Obsolescent_Feature
246 ("Numeric_Error is an " &
247 "obsolescent feature ('R'M 'J.6(1))?", Id
);
249 ("|use Constraint_Error instead?", Id
);
253 Check_Duplication
(Id
);
255 -- Check for exception declared within generic formal
256 -- package (which is illegal, see RM 11.2(8))
259 Ent
: Entity_Id
:= Entity
(Id
);
263 if Present
(Renamed_Entity
(Ent
)) then
264 Ent
:= Renamed_Entity
(Ent
);
268 while Scop
/= Standard_Standard
269 and then Ekind
(Scop
) = E_Package
271 -- If the exception is declared in an inner
272 -- instance, nothing else to check.
274 if Is_Generic_Instance
(Scop
) then
277 elsif Nkind
(Declaration_Node
(Scop
)) =
278 N_Package_Specification
280 Nkind
(Original_Node
(Parent
281 (Declaration_Node
(Scop
)))) =
282 N_Formal_Package_Declaration
285 ("exception& is declared in " &
286 "generic formal package", Id
, Ent
);
288 ("\and therefore cannot appear in " &
289 "handler ('R'M 11.2(8))", Id
);
293 Scop
:= Scope
(Scop
);
302 -- Check for redundant handler (has only raise statement) and
303 -- is either an others handler, or is a specific handler when
304 -- no others handler is present.
306 if Warn_On_Redundant_Constructs
307 and then List_Length
(Statements
(Handler
)) = 1
308 and then Nkind
(First
(Statements
(Handler
))) = N_Raise_Statement
309 and then No
(Name
(First
(Statements
(Handler
))))
310 and then (not Others_Present
311 or else Nkind
(First
(Exception_Choices
(Handler
))) =
315 ("useless handler contains only a reraise statement?",
319 -- Now analyze the statements of this handler
321 Analyze_Statements
(Statements
(Handler
));
323 -- If a choice was present, we created a special scope for it,
324 -- so this is where we pop that special scope to get rid of it.
326 if Present
(Choice
) then
333 end Analyze_Exception_Handlers
;
335 --------------------------------
336 -- Analyze_Handled_Statements --
337 --------------------------------
339 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
340 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
343 if Present
(Handlers
) then
347 Analyze_Statements
(Statements
(N
));
349 if Present
(Handlers
) then
350 Analyze_Exception_Handlers
(Handlers
);
352 elsif Present
(At_End_Proc
(N
)) then
353 Analyze
(At_End_Proc
(N
));
355 end Analyze_Handled_Statements
;
357 -----------------------------
358 -- Analyze_Raise_Statement --
359 -----------------------------
361 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
362 Exception_Id
: constant Node_Id
:= Name
(N
);
363 Exception_Name
: Entity_Id
:= Empty
;
368 Check_Unreachable_Code
(N
);
370 -- Check exception restrictions on the original source
372 if Comes_From_Source
(N
) then
373 Check_Restriction
(No_Exceptions
, N
);
376 -- Check for useless assignment to OUT or IN OUT scalar
377 -- immediately preceding the raise. Right now we only look
378 -- at assignment statements, we could do more.
380 if Is_List_Member
(N
) then
389 and then Nkind
(P
) = N_Assignment_Statement
393 if Is_Scalar_Type
(Etype
(L
))
394 and then Is_Entity_Name
(L
)
395 and then Is_Formal
(Entity
(L
))
398 ("?assignment to pass-by-copy formal may have no effect",
401 ("\?RAISE statement is abnormal return" &
402 " ('R'M 6.4.1(17))", P
);
410 if No
(Exception_Id
) then
413 Nkind_P
:= Nkind
(P
);
415 while Nkind_P
/= N_Exception_Handler
416 and then Nkind_P
/= N_Subprogram_Body
417 and then Nkind_P
/= N_Package_Body
418 and then Nkind_P
/= N_Task_Body
419 and then Nkind_P
/= N_Entry_Body
422 Nkind_P
:= Nkind
(P
);
425 if Nkind
(P
) /= N_Exception_Handler
then
427 ("reraise statement must appear directly in a handler", N
);
430 -- Normal case with exception id present
433 Analyze
(Exception_Id
);
435 if Is_Entity_Name
(Exception_Id
) then
436 Exception_Name
:= Entity
(Exception_Id
);
439 if No
(Exception_Name
)
440 or else Ekind
(Exception_Name
) /= E_Exception
443 ("exception name expected in raise statement", Exception_Id
);
446 end Analyze_Raise_Statement
;
448 -----------------------------
449 -- Analyze_Raise_xxx_Error --
450 -----------------------------
452 -- Normally, the Etype is already set (when this node is used within
453 -- an expression, since it is copied from the node which it rewrites).
454 -- If this node is used in a statement context, then we set the type
455 -- Standard_Void_Type. This is used both by Gigi and by the front end
456 -- to distinguish the statement use and the subexpression use.
458 -- The only other required processing is to take care of the Condition
459 -- field if one is present.
461 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
463 if No
(Etype
(N
)) then
464 Set_Etype
(N
, Standard_Void_Type
);
467 if Present
(Condition
(N
)) then
468 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
471 -- Deal with static cases in obvious manner
473 if Nkind
(Condition
(N
)) = N_Identifier
then
474 if Entity
(Condition
(N
)) = Standard_True
then
475 Set_Condition
(N
, Empty
);
477 elsif Entity
(Condition
(N
)) = Standard_False
then
478 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
482 end Analyze_Raise_xxx_Error
;
484 -----------------------------
485 -- Analyze_Subprogram_Info --
486 -----------------------------
488 procedure Analyze_Subprogram_Info
(N
: Node_Id
) is
490 Set_Etype
(N
, RTE
(RE_Code_Loc
));
491 end Analyze_Subprogram_Info
;