1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 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 Einfo
; use Einfo
;
29 with Errout
; use Errout
;
31 with Lib
.Xref
; use Lib
.Xref
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Restrict
; use Restrict
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Ch5
; use Sem_Ch5
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Res
; use Sem_Res
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Stand
; use Stand
;
44 with Uintp
; use Uintp
;
46 package body Sem_Ch11
is
48 -----------------------------------
49 -- Analyze_Exception_Declaration --
50 -----------------------------------
52 procedure Analyze_Exception_Declaration
(N
: Node_Id
) is
53 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
54 PF
: constant Boolean := Is_Pure
(Current_Scope
);
57 Generate_Definition
(Id
);
59 Set_Ekind
(Id
, E_Exception
);
60 Set_Exception_Code
(Id
, Uint_0
);
61 Set_Etype
(Id
, Standard_Exception_Type
);
63 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 -----------------------
82 -- Check_Duplication --
83 -----------------------
85 procedure Check_Duplication
(Id
: Node_Id
) is
90 Handler
:= First_Non_Pragma
(L
);
91 while Present
(Handler
) loop
92 Id1
:= First
(Exception_Choices
(Handler
));
94 while Present
(Id1
) loop
96 -- Only check against the exception choices which precede
97 -- Id in the handler, since the ones that follow Id have not
98 -- been analyzed yet and will be checked in a subsequent call.
103 elsif Nkind
(Id1
) /= N_Others_Choice
104 and then Entity
(Id
) = Entity
(Id1
)
106 if Handler
/= Parent
(Id
) then
107 Error_Msg_Sloc
:= Sloc
(Id1
);
109 ("exception choice duplicates &#", Id
, Id1
);
112 if Ada_83
and then Comes_From_Source
(Id
) then
114 ("(Ada 83): duplicate exception choice&", Id
);
119 Next_Non_Pragma
(Id1
);
124 end Check_Duplication
;
126 -- Start processing for Analyze_Exception_Handlers
129 Handler
:= First
(L
);
130 Check_Restriction
(No_Exceptions
, Handler
);
131 Check_Restriction
(No_Exception_Handlers
, Handler
);
133 -- Loop through handlers (which can include pragmas)
135 while Present
(Handler
) loop
137 -- If pragma just analyze it
139 if Nkind
(Handler
) = N_Pragma
then
142 -- Otherwise we have a real exception handler
145 -- Deal with choice parameter. The exception handler is
146 -- a declarative part for it, so it constitutes a scope
147 -- for visibility purposes. We create an entity to denote
148 -- the whole exception part, and use it as the scope of all
149 -- the choices, which may even have the same name without
150 -- conflict. This scope plays no other role in expansion or
151 -- or code generation.
153 Choice
:= Choice_Parameter
(Handler
);
155 if Present
(Choice
) then
158 H_Scope
:= New_Internal_Entity
159 (E_Block
, Current_Scope
, Sloc
(Choice
), 'E');
163 Set_Etype
(H_Scope
, Standard_Void_Type
);
165 -- Set the Finalization Chain entity to Error means that it
166 -- should not be used at that level but the parent one
167 -- should be used instead.
169 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
170 -- ??? using Error for this non-error condition is nasty ???
172 Set_Finalization_Chain_Entity
(H_Scope
, Error
);
175 Set_Ekind
(Choice
, E_Variable
);
176 Set_Etype
(Choice
, RTE
(RE_Exception_Occurrence
));
177 Generate_Definition
(Choice
);
180 Id
:= First
(Exception_Choices
(Handler
));
181 while Present
(Id
) loop
182 if Nkind
(Id
) = N_Others_Choice
then
183 if Present
(Next
(Id
))
184 or else Present
(Next
(Handler
))
185 or else Present
(Prev
(Id
))
187 Error_Msg_N
("OTHERS must appear alone and last", Id
);
193 if not Is_Entity_Name
(Id
)
194 or else Ekind
(Entity
(Id
)) /= E_Exception
196 Error_Msg_N
("exception name expected", Id
);
199 if Present
(Renamed_Entity
(Entity
(Id
))) then
200 Set_Entity
(Id
, Renamed_Entity
(Entity
(Id
)));
203 Check_Duplication
(Id
);
205 -- Check for exception declared within generic formal
206 -- package (which is illegal, see RM 11.2(8))
209 Ent
: Entity_Id
:= Entity
(Id
);
210 Scop
: Entity_Id
:= Scope
(Ent
);
213 while Scop
/= Standard_Standard
214 and then Ekind
(Scop
) = E_Package
216 -- If the exception is declared in an inner
217 -- instance, nothing else to check.
219 if Is_Generic_Instance
(Scop
) then
222 elsif Nkind
(Declaration_Node
(Scop
)) =
223 N_Package_Specification
225 Nkind
(Original_Node
(Parent
226 (Declaration_Node
(Scop
)))) =
227 N_Formal_Package_Declaration
230 ("exception& is declared in " &
231 "generic formal package", Id
, Ent
);
233 ("\and therefore cannot appear in " &
234 "handler ('R'M 11.2(8))", Id
);
238 Scop
:= Scope
(Scop
);
247 Analyze_Statements
(Statements
(Handler
));
249 if Present
(Choice
) then
257 end Analyze_Exception_Handlers
;
259 --------------------------------
260 -- Analyze_Handled_Statements --
261 --------------------------------
263 procedure Analyze_Handled_Statements
(N
: Node_Id
) is
264 Handlers
: constant List_Id
:= Exception_Handlers
(N
);
267 Analyze_Statements
(Statements
(N
));
269 if Present
(Handlers
) then
270 Analyze_Exception_Handlers
(Handlers
);
272 elsif Present
(At_End_Proc
(N
)) then
273 Analyze
(At_End_Proc
(N
));
275 end Analyze_Handled_Statements
;
277 -----------------------------
278 -- Analyze_Raise_Statement --
279 -----------------------------
281 procedure Analyze_Raise_Statement
(N
: Node_Id
) is
282 Exception_Id
: constant Node_Id
:= Name
(N
);
283 Exception_Name
: Entity_Id
:= Empty
;
288 Check_Unreachable_Code
(N
);
290 -- Check exception restrictions on the original source
292 if Comes_From_Source
(N
) then
293 Check_Restriction
(No_Exceptions
, N
);
298 if No
(Exception_Id
) then
301 Nkind_P
:= Nkind
(P
);
303 while Nkind_P
/= N_Exception_Handler
304 and then Nkind_P
/= N_Subprogram_Body
305 and then Nkind_P
/= N_Package_Body
306 and then Nkind_P
/= N_Task_Body
307 and then Nkind_P
/= N_Entry_Body
310 Nkind_P
:= Nkind
(P
);
313 if Nkind
(P
) /= N_Exception_Handler
then
315 ("reraise statement must appear directly in a handler", N
);
318 -- Normal case with exception id present
321 Analyze
(Exception_Id
);
323 if Is_Entity_Name
(Exception_Id
) then
324 Exception_Name
:= Entity
(Exception_Id
);
327 if No
(Exception_Name
)
328 or else Ekind
(Exception_Name
) /= E_Exception
331 ("exception name expected in raise statement", Exception_Id
);
334 end Analyze_Raise_Statement
;
336 -----------------------------
337 -- Analyze_Raise_xxx_Error --
338 -----------------------------
340 -- Normally, the Etype is already set (when this node is used within
341 -- an expression, since it is copied from the node which it rewrites).
342 -- If this node is used in a statement context, then we set the type
343 -- Standard_Void_Type. This is used both by Gigi and by the front end
344 -- to distinguish the statement use and the subexpression use.
346 -- The only other required processing is to take care of the Condition
347 -- field if one is present.
349 procedure Analyze_Raise_xxx_Error
(N
: Node_Id
) is
351 if No
(Etype
(N
)) then
352 Set_Etype
(N
, Standard_Void_Type
);
355 if Present
(Condition
(N
)) then
356 Analyze_And_Resolve
(Condition
(N
), Standard_Boolean
);
359 -- Deal with static cases in obvious manner
361 if Nkind
(Condition
(N
)) = N_Identifier
then
362 if Entity
(Condition
(N
)) = Standard_True
then
363 Set_Condition
(N
, Empty
);
365 elsif Entity
(Condition
(N
)) = Standard_False
then
366 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
370 end Analyze_Raise_xxx_Error
;
372 -----------------------------
373 -- Analyze_Subprogram_Info --
374 -----------------------------
376 procedure Analyze_Subprogram_Info
(N
: Node_Id
) is
378 Set_Etype
(N
, RTE
(RE_Code_Loc
));
379 end Analyze_Subprogram_Info
;