gcc:
[official-gcc.git] / gcc / ada / sem_ch11.adb
blob75ee081a16d71984060dbac0a954fcad49e5c2c3
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 1 1 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
10 -- --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Lib; use Lib;
32 with Lib.Xref; use Lib.Xref;
33 with Nlists; use Nlists;
34 with Nmake; use Nmake;
35 with Opt; use Opt;
36 with Restrict; use Restrict;
37 with Rident; use Rident;
38 with Rtsfind; use Rtsfind;
39 with Sem; use Sem;
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 begin
60 Generate_Definition (Id);
61 Enter_Name (Id);
62 Set_Ekind (Id, E_Exception);
63 Set_Exception_Code (Id, Uint_0);
64 Set_Etype (Id, Standard_Exception_Type);
66 Set_Is_Statically_Allocated (Id);
67 Set_Is_Pure (Id, PF);
68 end Analyze_Exception_Declaration;
70 --------------------------------
71 -- Analyze_Exception_Handlers --
72 --------------------------------
74 procedure Analyze_Exception_Handlers (L : List_Id) is
75 Handler : Node_Id;
76 Choice : Entity_Id;
77 Id : Node_Id;
78 H_Scope : Entity_Id := Empty;
80 procedure Check_Duplication (Id : Node_Id);
81 -- Iterate through the identifiers in each handler to find duplicates
83 function Others_Present return Boolean;
84 -- Returns True if others handler is present
86 -----------------------
87 -- Check_Duplication --
88 -----------------------
90 procedure Check_Duplication (Id : Node_Id) is
91 Handler : Node_Id;
92 Id1 : Node_Id;
93 Id_Entity : Entity_Id := Entity (Id);
95 begin
96 if Present (Renamed_Entity (Id_Entity)) then
97 Id_Entity := Renamed_Entity (Id_Entity);
98 end if;
100 Handler := First_Non_Pragma (L);
101 while Present (Handler) loop
102 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.
109 if Id = Id1 then
110 return;
112 elsif Nkind (Id1) /= N_Others_Choice
113 and then
114 (Id_Entity = Entity (Id1)
115 or else (Id_Entity = Renamed_Entity (Entity (Id1))))
116 then
117 if Handler /= Parent (Id) then
118 Error_Msg_Sloc := Sloc (Id1);
119 Error_Msg_NE
120 ("exception choice duplicates &#", Id, Id1);
122 else
123 if Ada_Version = Ada_83
124 and then Comes_From_Source (Id)
125 then
126 Error_Msg_N
127 ("(Ada 83): duplicate exception choice&", Id);
128 end if;
129 end if;
130 end if;
132 Next_Non_Pragma (Id1);
133 end loop;
135 Next (Handler);
136 end loop;
137 end Check_Duplication;
139 --------------------
140 -- Others_Present --
141 --------------------
143 function Others_Present return Boolean is
144 H : Node_Id;
146 begin
147 H := First (L);
148 while Present (H) loop
149 if Nkind (H) /= N_Pragma
150 and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
151 then
152 return True;
153 end if;
155 Next (H);
156 end loop;
158 return False;
159 end Others_Present;
161 -- Start processing for Analyze_Exception_Handlers
163 begin
164 Handler := First (L);
165 Check_Restriction (No_Exceptions, Handler);
166 Check_Restriction (No_Exception_Handlers, Handler);
168 -- Kill current remembered values, since we don't know where we were
169 -- when the exception was raised.
171 Kill_Current_Values;
173 -- Loop through handlers (which can include pragmas)
175 while Present (Handler) loop
177 -- If pragma just analyze it
179 if Nkind (Handler) = N_Pragma then
180 Analyze (Handler);
182 -- Otherwise we have a real exception handler
184 else
185 -- Deal with choice parameter. The exception handler is
186 -- a declarative part for it, so it constitutes a scope
187 -- for visibility purposes. We create an entity to denote
188 -- the whole exception part, and use it as the scope of all
189 -- the choices, which may even have the same name without
190 -- conflict. This scope plays no other role in expansion or
191 -- or code generation.
193 Choice := Choice_Parameter (Handler);
195 if Present (Choice) then
196 if No (H_Scope) then
197 H_Scope := New_Internal_Entity
198 (E_Block, Current_Scope, Sloc (Choice), 'E');
199 end if;
201 New_Scope (H_Scope);
202 Set_Etype (H_Scope, Standard_Void_Type);
204 -- Set the Finalization Chain entity to Error means that it
205 -- should not be used at that level but the parent one
206 -- should be used instead.
208 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
209 -- ??? using Error for this non-error condition is nasty ???
211 Set_Finalization_Chain_Entity (H_Scope, Error);
213 Enter_Name (Choice);
214 Set_Ekind (Choice, E_Variable);
215 Set_Etype (Choice, RTE (RE_Exception_Occurrence));
216 Generate_Definition (Choice);
218 -- Set source assigned flag, since in effect this field
219 -- is always assigned an initial value by the exception.
221 Set_Never_Set_In_Source (Choice, False);
222 end if;
224 Id := First (Exception_Choices (Handler));
225 while Present (Id) loop
226 if Nkind (Id) = N_Others_Choice then
227 if Present (Next (Id))
228 or else Present (Next (Handler))
229 or else Present (Prev (Id))
230 then
231 Error_Msg_N ("OTHERS must appear alone and last", Id);
232 end if;
234 else
235 Analyze (Id);
237 if not Is_Entity_Name (Id)
238 or else Ekind (Entity (Id)) /= E_Exception
239 then
240 Error_Msg_N ("exception name expected", Id);
242 else
243 if Present (Renamed_Entity (Entity (Id))) then
244 if Entity (Id) = Standard_Numeric_Error then
245 Check_Restriction (No_Obsolescent_Features, Id);
247 if Warn_On_Obsolescent_Feature then
248 Error_Msg_N
249 ("Numeric_Error is an " &
250 "obsolescent feature ('R'M 'J.6(1))?", Id);
251 Error_Msg_N
252 ("\use Constraint_Error instead?", Id);
253 end if;
254 end if;
255 end if;
257 Check_Duplication (Id);
259 -- Check for exception declared within generic formal
260 -- package (which is illegal, see RM 11.2(8))
262 declare
263 Ent : Entity_Id := Entity (Id);
264 Scop : Entity_Id;
266 begin
267 if Present (Renamed_Entity (Ent)) then
268 Ent := Renamed_Entity (Ent);
269 end if;
271 Scop := Scope (Ent);
272 while Scop /= Standard_Standard
273 and then Ekind (Scop) = E_Package
274 loop
275 if Nkind (Declaration_Node (Scop)) =
276 N_Package_Specification
277 and then
278 Nkind (Original_Node (Parent
279 (Declaration_Node (Scop)))) =
280 N_Formal_Package_Declaration
281 then
282 Error_Msg_NE
283 ("exception& is declared in " &
284 "generic formal package", Id, Ent);
285 Error_Msg_N
286 ("\and therefore cannot appear in " &
287 "handler ('R'M 11.2(8))", Id);
288 exit;
290 -- If the exception is declared in an inner
291 -- instance, nothing else to check.
293 elsif Is_Generic_Instance (Scop) then
294 exit;
295 end if;
297 Scop := Scope (Scop);
298 end loop;
299 end;
300 end if;
301 end if;
303 Next (Id);
304 end loop;
306 -- Check for redundant handler (has only raise statement) and
307 -- is either an others handler, or is a specific handler when
308 -- no others handler is present.
310 if Warn_On_Redundant_Constructs
311 and then List_Length (Statements (Handler)) = 1
312 and then Nkind (First (Statements (Handler))) = N_Raise_Statement
313 and then No (Name (First (Statements (Handler))))
314 and then (not Others_Present
315 or else Nkind (First (Exception_Choices (Handler))) =
316 N_Others_Choice)
317 then
318 Error_Msg_N
319 ("useless handler contains only a reraise statement?",
320 Handler);
321 end if;
323 -- Now analyze the statements of this handler
325 Analyze_Statements (Statements (Handler));
327 -- If a choice was present, we created a special scope for it,
328 -- so this is where we pop that special scope to get rid of it.
330 if Present (Choice) then
331 End_Scope;
332 end if;
333 end if;
335 Next (Handler);
336 end loop;
337 end Analyze_Exception_Handlers;
339 --------------------------------
340 -- Analyze_Handled_Statements --
341 --------------------------------
343 procedure Analyze_Handled_Statements (N : Node_Id) is
344 Handlers : constant List_Id := Exception_Handlers (N);
346 begin
347 if Present (Handlers) then
348 Kill_All_Checks;
349 end if;
351 -- Analyze statements in sequence
353 Analyze_Statements (Statements (N));
355 -- If the current scope is a subprogram, and there are no explicit
356 -- exception handlers, then this is the right place to check for
357 -- hanging useless assignments from the statement sequence of the
358 -- subprogram body.
360 if Is_Subprogram (Current_Scope) then
361 Warn_On_Useless_Assignments (Current_Scope);
362 end if;
364 -- Deal with handlers or AT END proc
366 if Present (Handlers) then
367 Analyze_Exception_Handlers (Handlers);
368 elsif Present (At_End_Proc (N)) then
369 Analyze (At_End_Proc (N));
370 end if;
371 end Analyze_Handled_Statements;
373 -----------------------------
374 -- Analyze_Raise_Statement --
375 -----------------------------
377 procedure Analyze_Raise_Statement (N : Node_Id) is
378 Exception_Id : constant Node_Id := Name (N);
379 Exception_Name : Entity_Id := Empty;
380 P : Node_Id;
381 Nkind_P : Node_Kind;
383 begin
384 Check_Unreachable_Code (N);
386 -- Check exception restrictions on the original source
388 if Comes_From_Source (N) then
389 Check_Restriction (No_Exceptions, N);
390 end if;
392 -- Check for useless assignment to OUT or IN OUT scalar
393 -- immediately preceding the raise. Right now we only look
394 -- at assignment statements, we could do more.
396 if Is_List_Member (N) then
397 declare
398 P : Node_Id;
399 L : Node_Id;
401 begin
402 P := Prev (N);
404 if Present (P)
405 and then Nkind (P) = N_Assignment_Statement
406 then
407 L := Name (P);
409 if Is_Scalar_Type (Etype (L))
410 and then Is_Entity_Name (L)
411 and then Is_Formal (Entity (L))
412 then
413 Error_Msg_N
414 ("?assignment to pass-by-copy formal may have no effect",
416 Error_Msg_N
417 ("\?RAISE statement may result in abnormal return" &
418 " ('R'M 6.4.1(17))", P);
419 end if;
420 end if;
421 end;
422 end if;
424 -- Reraise statement
426 if No (Exception_Id) then
428 P := Parent (N);
429 Nkind_P := Nkind (P);
431 while Nkind_P /= N_Exception_Handler
432 and then Nkind_P /= N_Subprogram_Body
433 and then Nkind_P /= N_Package_Body
434 and then Nkind_P /= N_Task_Body
435 and then Nkind_P /= N_Entry_Body
436 loop
437 P := Parent (P);
438 Nkind_P := Nkind (P);
439 end loop;
441 if Nkind (P) /= N_Exception_Handler then
442 Error_Msg_N
443 ("reraise statement must appear directly in a handler", N);
444 end if;
446 -- Normal case with exception id present
448 else
449 Analyze (Exception_Id);
451 if Is_Entity_Name (Exception_Id) then
452 Exception_Name := Entity (Exception_Id);
453 end if;
455 if No (Exception_Name)
456 or else Ekind (Exception_Name) /= E_Exception
457 then
458 Error_Msg_N
459 ("exception name expected in raise statement", Exception_Id);
460 end if;
462 if Present (Expression (N)) then
463 Analyze_And_Resolve (Expression (N), Standard_String);
464 end if;
465 end if;
466 end Analyze_Raise_Statement;
468 -----------------------------
469 -- Analyze_Raise_xxx_Error --
470 -----------------------------
472 -- Normally, the Etype is already set (when this node is used within
473 -- an expression, since it is copied from the node which it rewrites).
474 -- If this node is used in a statement context, then we set the type
475 -- Standard_Void_Type. This is used both by Gigi and by the front end
476 -- to distinguish the statement use and the subexpression use.
478 -- The only other required processing is to take care of the Condition
479 -- field if one is present.
481 procedure Analyze_Raise_xxx_Error (N : Node_Id) is
482 begin
483 if No (Etype (N)) then
484 Set_Etype (N, Standard_Void_Type);
485 end if;
487 if Present (Condition (N)) then
488 Analyze_And_Resolve (Condition (N), Standard_Boolean);
489 end if;
491 -- Deal with static cases in obvious manner
493 if Nkind (Condition (N)) = N_Identifier then
494 if Entity (Condition (N)) = Standard_True then
495 Set_Condition (N, Empty);
497 elsif Entity (Condition (N)) = Standard_False then
498 Rewrite (N, Make_Null_Statement (Sloc (N)));
499 end if;
500 end if;
501 end Analyze_Raise_xxx_Error;
503 -----------------------------
504 -- Analyze_Subprogram_Info --
505 -----------------------------
507 procedure Analyze_Subprogram_Info (N : Node_Id) is
508 begin
509 Set_Etype (N, RTE (RE_Code_Loc));
510 end Analyze_Subprogram_Info;
512 end Sem_Ch11;