Mark ChangeLog
[official-gcc.git] / gcc / ada / sem_ch11.adb
blobbd3faa4c8c223a15b33e38ffd0f0816ae929e99b
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-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 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);
58 begin
59 Generate_Definition (Id);
60 Enter_Name (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);
66 Set_Is_Pure (Id, PF);
67 end Analyze_Exception_Declaration;
69 --------------------------------
70 -- Analyze_Exception_Handlers --
71 --------------------------------
73 procedure Analyze_Exception_Handlers (L : List_Id) is
74 Handler : Node_Id;
75 Choice : Entity_Id;
76 Id : Node_Id;
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
90 Handler : Node_Id;
91 Id1 : Node_Id;
92 Id_Entity : Entity_Id := Entity (Id);
94 begin
95 if Present (Renamed_Entity (Id_Entity)) then
96 Id_Entity := Renamed_Entity (Id_Entity);
97 end if;
99 Handler := First_Non_Pragma (L);
100 while Present (Handler) loop
101 Id1 := First (Exception_Choices (Handler));
102 while Present (Id1) loop
104 -- Only check against the exception choices which precede
105 -- Id in the handler, since the ones that follow Id have not
106 -- been analyzed yet and will be checked in a subsequent call.
108 if Id = Id1 then
109 return;
111 elsif Nkind (Id1) /= N_Others_Choice
112 and then
113 (Id_Entity = Entity (Id1)
114 or else (Id_Entity = Renamed_Entity (Entity (Id1))))
115 then
116 if Handler /= Parent (Id) then
117 Error_Msg_Sloc := Sloc (Id1);
118 Error_Msg_NE
119 ("exception choice duplicates &#", Id, Id1);
121 else
122 if Ada_Version = Ada_83
123 and then Comes_From_Source (Id)
124 then
125 Error_Msg_N
126 ("(Ada 83): duplicate exception choice&", Id);
127 end if;
128 end if;
129 end if;
131 Next_Non_Pragma (Id1);
132 end loop;
134 Next (Handler);
135 end loop;
136 end Check_Duplication;
138 --------------------
139 -- Others_Present --
140 --------------------
142 function Others_Present return Boolean is
143 H : Node_Id;
145 begin
146 H := First (L);
147 while Present (H) loop
148 if Nkind (H) /= N_Pragma
149 and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
150 then
151 return True;
152 end if;
154 Next (H);
155 end loop;
157 return False;
158 end Others_Present;
160 -- Start processing for Analyze_Exception_Handlers
162 begin
163 Handler := First (L);
164 Check_Restriction (No_Exceptions, Handler);
165 Check_Restriction (No_Exception_Handlers, Handler);
167 -- Kill current remembered values, since we don't know where we were
168 -- when the exception was raised.
170 Kill_Current_Values;
172 -- Loop through handlers (which can include pragmas)
174 while Present (Handler) loop
176 -- If pragma just analyze it
178 if Nkind (Handler) = N_Pragma then
179 Analyze (Handler);
181 -- Otherwise we have a real exception handler
183 else
184 -- Deal with choice parameter. The exception handler is
185 -- a declarative part for it, so it constitutes a scope
186 -- for visibility purposes. We create an entity to denote
187 -- the whole exception part, and use it as the scope of all
188 -- the choices, which may even have the same name without
189 -- conflict. This scope plays no other role in expansion or
190 -- or code generation.
192 Choice := Choice_Parameter (Handler);
194 if Present (Choice) then
195 if No (H_Scope) then
196 H_Scope := New_Internal_Entity
197 (E_Block, Current_Scope, Sloc (Choice), 'E');
198 end if;
200 New_Scope (H_Scope);
201 Set_Etype (H_Scope, Standard_Void_Type);
203 -- Set the Finalization Chain entity to Error means that it
204 -- should not be used at that level but the parent one
205 -- should be used instead.
207 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
208 -- ??? using Error for this non-error condition is nasty ???
210 Set_Finalization_Chain_Entity (H_Scope, Error);
212 Enter_Name (Choice);
213 Set_Ekind (Choice, E_Variable);
214 Set_Etype (Choice, RTE (RE_Exception_Occurrence));
215 Generate_Definition (Choice);
217 -- Set source assigned flag, since in effect this field
218 -- is always assigned an initial value by the exception.
220 Set_Never_Set_In_Source (Choice, False);
221 end if;
223 Id := First (Exception_Choices (Handler));
224 while Present (Id) loop
225 if Nkind (Id) = N_Others_Choice then
226 if Present (Next (Id))
227 or else Present (Next (Handler))
228 or else Present (Prev (Id))
229 then
230 Error_Msg_N ("OTHERS must appear alone and last", Id);
231 end if;
233 else
234 Analyze (Id);
236 if not Is_Entity_Name (Id)
237 or else Ekind (Entity (Id)) /= E_Exception
238 then
239 Error_Msg_N ("exception name expected", Id);
241 else
242 if Present (Renamed_Entity (Entity (Id))) then
243 if Entity (Id) = Standard_Numeric_Error then
244 Check_Restriction (No_Obsolescent_Features, Id);
246 if Warn_On_Obsolescent_Feature then
247 Error_Msg_N
248 ("Numeric_Error is an " &
249 "obsolescent feature ('R'M 'J.6(1))?", Id);
250 Error_Msg_N
251 ("\use Constraint_Error instead?", Id);
252 end if;
253 end if;
254 end if;
256 Check_Duplication (Id);
258 -- Check for exception declared within generic formal
259 -- package (which is illegal, see RM 11.2(8))
261 declare
262 Ent : Entity_Id := Entity (Id);
263 Scop : Entity_Id;
265 begin
266 if Present (Renamed_Entity (Ent)) then
267 Ent := Renamed_Entity (Ent);
268 end if;
270 Scop := Scope (Ent);
271 while Scop /= Standard_Standard
272 and then Ekind (Scop) = E_Package
273 loop
274 -- If the exception is declared in an inner
275 -- instance, nothing else to check.
277 if Is_Generic_Instance (Scop) then
278 exit;
280 elsif Nkind (Declaration_Node (Scop)) =
281 N_Package_Specification
282 and then
283 Nkind (Original_Node (Parent
284 (Declaration_Node (Scop)))) =
285 N_Formal_Package_Declaration
286 then
287 Error_Msg_NE
288 ("exception& is declared in " &
289 "generic formal package", Id, Ent);
290 Error_Msg_N
291 ("\and therefore cannot appear in " &
292 "handler ('R'M 11.2(8))", Id);
293 exit;
294 end if;
296 Scop := Scope (Scop);
297 end loop;
298 end;
299 end if;
300 end if;
302 Next (Id);
303 end loop;
305 -- Check for redundant handler (has only raise statement) and
306 -- is either an others handler, or is a specific handler when
307 -- no others handler is present.
309 if Warn_On_Redundant_Constructs
310 and then List_Length (Statements (Handler)) = 1
311 and then Nkind (First (Statements (Handler))) = N_Raise_Statement
312 and then No (Name (First (Statements (Handler))))
313 and then (not Others_Present
314 or else Nkind (First (Exception_Choices (Handler))) =
315 N_Others_Choice)
316 then
317 Error_Msg_N
318 ("useless handler contains only a reraise statement?",
319 Handler);
320 end if;
322 -- Now analyze the statements of this handler
324 Analyze_Statements (Statements (Handler));
326 -- If a choice was present, we created a special scope for it,
327 -- so this is where we pop that special scope to get rid of it.
329 if Present (Choice) then
330 End_Scope;
331 end if;
332 end if;
334 Next (Handler);
335 end loop;
336 end Analyze_Exception_Handlers;
338 --------------------------------
339 -- Analyze_Handled_Statements --
340 --------------------------------
342 procedure Analyze_Handled_Statements (N : Node_Id) is
343 Handlers : constant List_Id := Exception_Handlers (N);
345 begin
346 if Present (Handlers) then
347 Kill_All_Checks;
348 end if;
350 Analyze_Statements (Statements (N));
352 if Present (Handlers) then
353 Analyze_Exception_Handlers (Handlers);
355 elsif Present (At_End_Proc (N)) then
356 Analyze (At_End_Proc (N));
357 end if;
358 end Analyze_Handled_Statements;
360 -----------------------------
361 -- Analyze_Raise_Statement --
362 -----------------------------
364 procedure Analyze_Raise_Statement (N : Node_Id) is
365 Exception_Id : constant Node_Id := Name (N);
366 Exception_Name : Entity_Id := Empty;
367 P : Node_Id;
368 Nkind_P : Node_Kind;
370 begin
371 Check_Unreachable_Code (N);
373 -- Check exception restrictions on the original source
375 if Comes_From_Source (N) then
376 Check_Restriction (No_Exceptions, N);
377 end if;
379 -- Check for useless assignment to OUT or IN OUT scalar
380 -- immediately preceding the raise. Right now we only look
381 -- at assignment statements, we could do more.
383 if Is_List_Member (N) then
384 declare
385 P : Node_Id;
386 L : Node_Id;
388 begin
389 P := Prev (N);
391 if Present (P)
392 and then Nkind (P) = N_Assignment_Statement
393 then
394 L := Name (P);
396 if Is_Scalar_Type (Etype (L))
397 and then Is_Entity_Name (L)
398 and then Is_Formal (Entity (L))
399 then
400 Error_Msg_N
401 ("?assignment to pass-by-copy formal may have no effect",
403 Error_Msg_N
404 ("\?RAISE statement is abnormal return" &
405 " ('R'M 6.4.1(17))", P);
406 end if;
407 end if;
408 end;
409 end if;
411 -- Reraise statement
413 if No (Exception_Id) then
415 P := Parent (N);
416 Nkind_P := Nkind (P);
418 while Nkind_P /= N_Exception_Handler
419 and then Nkind_P /= N_Subprogram_Body
420 and then Nkind_P /= N_Package_Body
421 and then Nkind_P /= N_Task_Body
422 and then Nkind_P /= N_Entry_Body
423 loop
424 P := Parent (P);
425 Nkind_P := Nkind (P);
426 end loop;
428 if Nkind (P) /= N_Exception_Handler then
429 Error_Msg_N
430 ("reraise statement must appear directly in a handler", N);
431 end if;
433 -- Normal case with exception id present
435 else
436 Analyze (Exception_Id);
438 if Is_Entity_Name (Exception_Id) then
439 Exception_Name := Entity (Exception_Id);
440 end if;
442 if No (Exception_Name)
443 or else Ekind (Exception_Name) /= E_Exception
444 then
445 Error_Msg_N
446 ("exception name expected in raise statement", Exception_Id);
447 end if;
448 end if;
449 end Analyze_Raise_Statement;
451 -----------------------------
452 -- Analyze_Raise_xxx_Error --
453 -----------------------------
455 -- Normally, the Etype is already set (when this node is used within
456 -- an expression, since it is copied from the node which it rewrites).
457 -- If this node is used in a statement context, then we set the type
458 -- Standard_Void_Type. This is used both by Gigi and by the front end
459 -- to distinguish the statement use and the subexpression use.
461 -- The only other required processing is to take care of the Condition
462 -- field if one is present.
464 procedure Analyze_Raise_xxx_Error (N : Node_Id) is
465 begin
466 if No (Etype (N)) then
467 Set_Etype (N, Standard_Void_Type);
468 end if;
470 if Present (Condition (N)) then
471 Analyze_And_Resolve (Condition (N), Standard_Boolean);
472 end if;
474 -- Deal with static cases in obvious manner
476 if Nkind (Condition (N)) = N_Identifier then
477 if Entity (Condition (N)) = Standard_True then
478 Set_Condition (N, Empty);
480 elsif Entity (Condition (N)) = Standard_False then
481 Rewrite (N, Make_Null_Statement (Sloc (N)));
482 end if;
483 end if;
484 end Analyze_Raise_xxx_Error;
486 -----------------------------
487 -- Analyze_Subprogram_Info --
488 -----------------------------
490 procedure Analyze_Subprogram_Info (N : Node_Id) is
491 begin
492 Set_Etype (N, RTE (RE_Code_Loc));
493 end Analyze_Subprogram_Info;
495 end Sem_Ch11;