1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 of 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 code generation.
190 Choice := Choice_Parameter (Handler);
192 if Present (Choice) then
193 Set_Local_Raise_Not_OK (Handler);
195 if Comes_From_Source (Choice) then
196 Check_Restriction (No_Exception_Propagation, Choice);
202 (E_Block, Current_Scope, Sloc (Choice), 'E');
205 Push_Scope (H_Scope);
206 Set_Etype (H_Scope, Standard_Void_Type);
208 -- Set the Finalization Chain entity to Error means that it
209 -- should not be used at that level but the parent one should
212 -- ??? this usage needs documenting in Einfo/Exp_Ch7 ???
213 -- ??? using Error for this non-error condition is nasty ???
215 Set_Finalization_Chain_Entity (H_Scope, Error);
218 Set_Ekind (Choice, E_Variable);
220 if RTE_Available (RE_Exception_Occurrence) then
221 Set_Etype (Choice, RTE (RE_Exception_Occurrence));
224 Generate_Definition (Choice);
226 -- Indicate that choice has an initial value, since in effect
227 -- this field is assigned an initial value by the exception.
228 -- We also consider that it is modified in the source.
230 Set_Has_Initial_Value (Choice, True);
231 Set_Never_Set_In_Source (Choice, False);
234 Id := First (Exception_Choices (Handler));
235 while Present (Id) loop
236 if Nkind (Id) = N_Others_Choice then
237 if Present (Next (Id))
238 or else Present (Next (Handler))
239 or else Present (Prev (Id))
241 Error_Msg_N ("OTHERS must appear alone and last", Id);
247 -- In most cases the choice has already been analyzed in
248 -- Analyze_Handled_Statement_Sequence, in order to expand
249 -- local handlers. This advance analysis does not take into
250 -- account the case in which a choice has the same name as
251 -- the choice parameter of the handler, which may hide an
252 -- outer exception. This pathological case appears in ACATS
253 -- B80001_3.adb, and requires an explicit check to verify
254 -- that the id is not hidden.
256 if not Is_Entity_Name (Id)
257 or else Ekind (Entity (Id)) /= E_Exception
259 (Nkind (Id) = N_Identifier
260 and then Chars (Id) = Chars (Choice))
262 Error_Msg_N ("exception name expected", Id);
265 -- Emit a warning at the declaration level when a local
266 -- exception is never raised explicitly.
268 if Warn_On_Redundant_Constructs
269 and then not Is_Raised (Entity (Id))
270 and then Scope (Entity (Id)) = Current_Scope
273 ("?exception & is never raised", Entity (Id), Id);
276 if Present (Renamed_Entity (Entity (Id))) then
277 if Entity (Id) = Standard_Numeric_Error then
278 Check_Restriction (No_Obsolescent_Features, Id);
280 if Warn_On_Obsolescent_Feature then
282 ("Numeric_Error is an " &
283 "obsolescent feature (RM J.6(1))?", Id);
285 ("\use Constraint_Error instead?", Id);
290 Check_Duplication (Id);
292 -- Check for exception declared within generic formal
293 -- package (which is illegal, see RM 11.2(8))
296 Ent : Entity_Id := Entity (Id);
300 if Present (Renamed_Entity (Ent)) then
301 Ent := Renamed_Entity (Ent);
305 while Scop /= Standard_Standard
306 and then Ekind (Scop) = E_Package
308 if Nkind (Declaration_Node (Scop)) =
309 N_Package_Specification
311 Nkind (Original_Node (Parent
312 (Declaration_Node (Scop)))) =
313 N_Formal_Package_Declaration
316 ("exception& is declared in " &
317 "generic formal package", Id, Ent);
319 ("\and therefore cannot appear in " &
320 "handler (RM 11.2(8))", Id);
323 -- If the exception is declared in an inner
324 -- instance, nothing else to check.
326 elsif Is_Generic_Instance (Scop) then
330 Scop := Scope (Scop);
339 -- Check for redundant handler (has only raise statement) and is
340 -- either an others handler, or is a specific handler when no
341 -- others handler is present.
343 if Warn_On_Redundant_Constructs
344 and then List_Length (Statements (Handler)) = 1
345 and then Nkind (First (Statements (Handler))) = N_Raise_Statement
346 and then No (Name (First (Statements (Handler))))
347 and then (not Others_Present
348 or else Nkind (First (Exception_Choices (Handler))) =
352 ("useless handler contains only a reraise statement?",
356 -- Now analyze the statements of this handler
358 Analyze_Statements (Statements (Handler));
360 -- If a choice was present, we created a special scope for it,
361 -- so this is where we pop that special scope to get rid of it.
363 if Present (Choice) then
370 end Analyze_Exception_Handlers;
372 --------------------------------
373 -- Analyze_Handled_Statements --
374 --------------------------------
376 procedure Analyze_Handled_Statements (N : Node_Id) is
377 Handlers : constant List_Id := Exception_Handlers (N);
382 if Present (Handlers) then
386 -- We are now going to analyze the statements and then the exception
387 -- handlers. We certainly need to do things in this order to get the
388 -- proper sequential semantics for various warnings.
390 -- However, there is a glitch. When we process raise statements, an
391 -- optimization is to look for local handlers and specialize the code
394 -- In order to detect if a handler is matching, we must have at least
395 -- analyzed the choices in the proper scope so that proper visibility
396 -- analysis is performed. Hence we analyze just the choices first,
397 -- before we analyze the statement sequence.
399 Handler := First_Non_Pragma (Handlers);
400 while Present (Handler) loop
401 Choice := First_Non_Pragma (Exception_Choices (Handler));
402 while Present (Choice) loop
404 Next_Non_Pragma (Choice);
407 Next_Non_Pragma (Handler);
410 -- Analyze statements in sequence
412 Analyze_Statements (Statements (N));
414 -- If the current scope is a subprogram, then this is the right place to
415 -- check for hanging useless assignments from the statement sequence of
416 -- the subprogram body.
418 if Is_Subprogram (Current_Scope) then
419 Warn_On_Useless_Assignments (Current_Scope);
422 -- Deal with handlers or AT END proc
424 if Present (Handlers) then
425 Analyze_Exception_Handlers (Handlers);
426 elsif Present (At_End_Proc (N)) then
427 Analyze (At_End_Proc (N));
429 end Analyze_Handled_Statements;
431 -----------------------------
432 -- Analyze_Raise_Statement --
433 -----------------------------
435 procedure Analyze_Raise_Statement (N : Node_Id) is
436 Exception_Id : constant Node_Id := Name (N);
437 Exception_Name : Entity_Id := Empty;
441 Check_Unreachable_Code (N);
443 -- Check exception restrictions on the original source
445 if Comes_From_Source (N) then
446 Check_Restriction (No_Exceptions, N);
449 -- Check for useless assignment to OUT or IN OUT scalar immediately
450 -- preceding the raise. Right now we only look at assignment statements,
453 if Is_List_Member (N) then
462 and then Nkind (P) = N_Assignment_Statement
466 if Is_Scalar_Type (Etype (L))
467 and then Is_Entity_Name (L)
468 and then Is_Formal (Entity (L))
471 ("?assignment to pass-by-copy formal may have no effect",
474 ("\?RAISE statement may result in abnormal return" &
475 " (RM 6.4.1(17))", P);
483 if No (Exception_Id) then
485 while not Nkind_In (P, N_Exception_Handler,
494 if Nkind (P) /= N_Exception_Handler then
496 ("reraise statement must appear directly in a handler", N);
498 -- If a handler has a reraise, it cannot be the target of a local
499 -- raise (goto optimization is impossible), and if the no exception
500 -- propagation restriction is set, this is a violation.
503 Set_Local_Raise_Not_OK (P);
505 -- Do not check the restriction if the reraise statement is part
506 -- of the code generated for an AT-END handler. That's because
507 -- if the restriction is actually active, we never generate this
508 -- raise anyway, so the apparent violation is bogus.
510 if not From_At_End (N) then
511 Check_Restriction (No_Exception_Propagation, N);
515 -- Normal case with exception id present
518 Analyze (Exception_Id);
520 if Is_Entity_Name (Exception_Id) then
521 Exception_Name := Entity (Exception_Id);
524 if No (Exception_Name)
525 or else Ekind (Exception_Name) /= E_Exception
528 ("exception name expected in raise statement", Exception_Id);
530 Set_Is_Raised (Exception_Name);
533 -- Deal with RAISE WITH case
535 if Present (Expression (N)) then
536 Check_Compiler_Unit (Expression (N));
537 Analyze_And_Resolve (Expression (N), Standard_String);
541 Kill_Current_Values (Last_Assignment_Only => True);
542 end Analyze_Raise_Statement;
544 -----------------------------
545 -- Analyze_Raise_xxx_Error --
546 -----------------------------
548 -- Normally, the Etype is already set (when this node is used within
549 -- an expression, since it is copied from the node which it rewrites).
550 -- If this node is used in a statement context, then we set the type
551 -- Standard_Void_Type. This is used both by Gigi and by the front end
552 -- to distinguish the statement use and the subexpression use.
554 -- The only other required processing is to take care of the Condition
555 -- field if one is present.
557 procedure Analyze_Raise_xxx_Error (N : Node_Id) is
559 function Same_Expression (C1, C2 : Node_Id) return Boolean;
560 -- It often occurs that two identical raise statements are generated in
561 -- succession (for example when dynamic elaboration checks take place on
562 -- separate expressions in a call). If the two statements are identical
563 -- according to the simple criterion that follows, the raise is
564 -- converted into a null statement.
566 ---------------------
567 -- Same_Expression --
568 ---------------------
570 function Same_Expression (C1, C2 : Node_Id) return Boolean is
572 if No (C1) and then No (C2) then
575 elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
576 return Entity (C1) = Entity (C2);
578 elsif Nkind (C1) /= Nkind (C2) then
581 elsif Nkind (C1) in N_Unary_Op then
582 return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
584 elsif Nkind (C1) in N_Binary_Op then
585 return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
586 and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
588 elsif Nkind (C1) = N_Null then
596 -- Start of processing for Analyze_Raise_xxx_Error
599 if No (Etype (N)) then
600 Set_Etype (N, Standard_Void_Type);
603 if Present (Condition (N)) then
604 Analyze_And_Resolve (Condition (N), Standard_Boolean);
607 -- Deal with static cases in obvious manner
609 if Nkind (Condition (N)) = N_Identifier then
610 if Entity (Condition (N)) = Standard_True then
611 Set_Condition (N, Empty);
613 elsif Entity (Condition (N)) = Standard_False then
614 Rewrite (N, Make_Null_Statement (Sloc (N)));
618 -- Remove duplicate raise statements. Note that the previous one may
619 -- already have been removed as well.
621 if not Comes_From_Source (N)
622 and then Nkind (N) /= N_Null_Statement
623 and then Is_List_Member (N)
624 and then Present (Prev (N))
625 and then Nkind (N) = Nkind (Original_Node (Prev (N)))
626 and then Same_Expression
627 (Condition (N), Condition (Original_Node (Prev (N))))
629 Rewrite (N, Make_Null_Statement (Sloc (N)));
631 end Analyze_Raise_xxx_Error;
633 -----------------------------
634 -- Analyze_Subprogram_Info --
635 -----------------------------
637 procedure Analyze_Subprogram_Info (N : Node_Id) is
639 Set_Etype (N, RTE (RE_Code_Loc));
640 end Analyze_Subprogram_Info;