| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 1 1 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Einfo; use Einfo; |
| with Errout; use Errout; |
| with Lib; use Lib; |
| with Lib.Xref; use Lib.Xref; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Ch5; use Sem_Ch5; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Stand; use Stand; |
| with Uintp; use Uintp; |
| |
| package body Sem_Ch11 is |
| |
| ----------------------------------- |
| -- Analyze_Exception_Declaration -- |
| ----------------------------------- |
| |
| procedure Analyze_Exception_Declaration (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (N); |
| PF : constant Boolean := Is_Pure (Current_Scope); |
| |
| begin |
| Generate_Definition (Id); |
| Enter_Name (Id); |
| Set_Ekind (Id, E_Exception); |
| Set_Exception_Code (Id, Uint_0); |
| Set_Etype (Id, Standard_Exception_Type); |
| |
| Set_Is_Statically_Allocated (Id); |
| Set_Is_Pure (Id, PF); |
| end Analyze_Exception_Declaration; |
| |
| -------------------------------- |
| -- Analyze_Exception_Handlers -- |
| -------------------------------- |
| |
| procedure Analyze_Exception_Handlers (L : List_Id) is |
| Handler : Node_Id; |
| Choice : Entity_Id; |
| Id : Node_Id; |
| H_Scope : Entity_Id := Empty; |
| |
| procedure Check_Duplication (Id : Node_Id); |
| -- Iterate through the identifiers in each handler to find duplicates |
| |
| function Others_Present return Boolean; |
| -- Returns True if others handler is present |
| |
| ----------------------- |
| -- Check_Duplication -- |
| ----------------------- |
| |
| procedure Check_Duplication (Id : Node_Id) is |
| Handler : Node_Id; |
| Id1 : Node_Id; |
| Id_Entity : Entity_Id := Entity (Id); |
| |
| begin |
| if Present (Renamed_Entity (Id_Entity)) then |
| Id_Entity := Renamed_Entity (Id_Entity); |
| end if; |
| |
| Handler := First_Non_Pragma (L); |
| while Present (Handler) loop |
| Id1 := First (Exception_Choices (Handler)); |
| |
| while Present (Id1) loop |
| |
| -- Only check against the exception choices which precede |
| -- Id in the handler, since the ones that follow Id have not |
| -- been analyzed yet and will be checked in a subsequent call. |
| |
| if Id = Id1 then |
| return; |
| |
| elsif Nkind (Id1) /= N_Others_Choice |
| and then |
| (Id_Entity = Entity (Id1) |
| or else (Id_Entity = Renamed_Entity (Entity (Id1)))) |
| then |
| if Handler /= Parent (Id) then |
| Error_Msg_Sloc := Sloc (Id1); |
| Error_Msg_NE |
| ("exception choice duplicates &#", Id, Id1); |
| |
| else |
| if Ada_83 and then Comes_From_Source (Id) then |
| Error_Msg_N |
| ("(Ada 83): duplicate exception choice&", Id); |
| end if; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Id1); |
| end loop; |
| |
| Next (Handler); |
| end loop; |
| end Check_Duplication; |
| |
| -------------------- |
| -- Others_Present -- |
| -------------------- |
| |
| function Others_Present return Boolean is |
| H : Node_Id; |
| |
| begin |
| H := First (L); |
| while Present (H) loop |
| if Nkind (H) /= N_Pragma |
| and then Nkind (First (Exception_Choices (H))) = N_Others_Choice |
| then |
| return True; |
| end if; |
| |
| Next (H); |
| end loop; |
| |
| return False; |
| end Others_Present; |
| |
| -- Start processing for Analyze_Exception_Handlers |
| |
| begin |
| Handler := First (L); |
| Check_Restriction (No_Exceptions, Handler); |
| Check_Restriction (No_Exception_Handlers, Handler); |
| |
| -- Kill current remembered values, since we don't know where we were |
| -- when the exception was raised. |
| |
| Kill_Current_Values; |
| |
| -- Loop through handlers (which can include pragmas) |
| |
| while Present (Handler) loop |
| |
| -- If pragma just analyze it |
| |
| if Nkind (Handler) = N_Pragma then |
| Analyze (Handler); |
| |
| -- Otherwise we have a real exception handler |
| |
| else |
| -- Deal with choice parameter. The exception handler is |
| -- a declarative part for it, so it constitutes a scope |
| -- for visibility purposes. We create an entity to denote |
| -- the whole exception part, and use it as the scope of all |
| -- the choices, which may even have the same name without |
| -- conflict. This scope plays no other role in expansion or |
| -- or code generation. |
| |
| Choice := Choice_Parameter (Handler); |
| |
| if Present (Choice) then |
| if No (H_Scope) then |
| H_Scope := New_Internal_Entity |
| (E_Block, Current_Scope, Sloc (Choice), 'E'); |
| end if; |
| |
| New_Scope (H_Scope); |
| Set_Etype (H_Scope, Standard_Void_Type); |
| |
| -- Set the Finalization Chain entity to Error means that it |
| -- should not be used at that level but the parent one |
| -- should be used instead. |
| |
| -- ??? this usage needs documenting in Einfo/Exp_Ch7 ??? |
| -- ??? using Error for this non-error condition is nasty ??? |
| |
| Set_Finalization_Chain_Entity (H_Scope, Error); |
| |
| Enter_Name (Choice); |
| Set_Ekind (Choice, E_Variable); |
| Set_Etype (Choice, RTE (RE_Exception_Occurrence)); |
| Generate_Definition (Choice); |
| |
| -- Set source assigned flag, since in effect this field |
| -- is always assigned an initial value by the exception. |
| |
| Set_Never_Set_In_Source (Choice, False); |
| end if; |
| |
| Id := First (Exception_Choices (Handler)); |
| while Present (Id) loop |
| if Nkind (Id) = N_Others_Choice then |
| if Present (Next (Id)) |
| or else Present (Next (Handler)) |
| or else Present (Prev (Id)) |
| then |
| Error_Msg_N ("OTHERS must appear alone and last", Id); |
| end if; |
| |
| else |
| Analyze (Id); |
| |
| if not Is_Entity_Name (Id) |
| or else Ekind (Entity (Id)) /= E_Exception |
| then |
| Error_Msg_N ("exception name expected", Id); |
| |
| else |
| if Present (Renamed_Entity (Entity (Id))) then |
| if Entity (Id) = Standard_Numeric_Error |
| and then Warn_On_Obsolescent_Feature |
| then |
| Error_Msg_N |
| ("Numeric_Error is an " & |
| "obsolescent feature ('R'M 'J.6(1))?", Id); |
| Error_Msg_N |
| ("|use Constraint_Error instead?", Id); |
| end if; |
| end if; |
| |
| Check_Duplication (Id); |
| |
| -- Check for exception declared within generic formal |
| -- package (which is illegal, see RM 11.2(8)) |
| |
| declare |
| Ent : Entity_Id := Entity (Id); |
| Scop : Entity_Id; |
| |
| begin |
| if Present (Renamed_Entity (Ent)) then |
| Ent := Renamed_Entity (Ent); |
| end if; |
| |
| Scop := Scope (Ent); |
| while Scop /= Standard_Standard |
| and then Ekind (Scop) = E_Package |
| loop |
| -- If the exception is declared in an inner |
| -- instance, nothing else to check. |
| |
| if Is_Generic_Instance (Scop) then |
| exit; |
| |
| elsif Nkind (Declaration_Node (Scop)) = |
| N_Package_Specification |
| and then |
| Nkind (Original_Node (Parent |
| (Declaration_Node (Scop)))) = |
| N_Formal_Package_Declaration |
| then |
| Error_Msg_NE |
| ("exception& is declared in " & |
| "generic formal package", Id, Ent); |
| Error_Msg_N |
| ("\and therefore cannot appear in " & |
| "handler ('R'M 11.2(8))", Id); |
| exit; |
| end if; |
| |
| Scop := Scope (Scop); |
| end loop; |
| end; |
| end if; |
| end if; |
| |
| Next (Id); |
| end loop; |
| |
| -- Check for redundant handler (has only raise statement) and |
| -- is either an others handler, or is a specific handler when |
| -- no others handler is present. |
| |
| if Warn_On_Redundant_Constructs |
| and then List_Length (Statements (Handler)) = 1 |
| and then Nkind (First (Statements (Handler))) = N_Raise_Statement |
| and then No (Name (First (Statements (Handler)))) |
| and then (not Others_Present |
| or else Nkind (First (Exception_Choices (Handler))) = |
| N_Others_Choice) |
| then |
| Error_Msg_N |
| ("useless handler contains only a reraise statement?", |
| Handler); |
| end if; |
| |
| -- Now analyze the statements of this handler |
| |
| Analyze_Statements (Statements (Handler)); |
| |
| -- If a choice was present, we created a special scope for it, |
| -- so this is where we pop that special scope to get rid of it. |
| |
| if Present (Choice) then |
| End_Scope; |
| end if; |
| end if; |
| |
| Next (Handler); |
| end loop; |
| end Analyze_Exception_Handlers; |
| |
| -------------------------------- |
| -- Analyze_Handled_Statements -- |
| -------------------------------- |
| |
| procedure Analyze_Handled_Statements (N : Node_Id) is |
| Handlers : constant List_Id := Exception_Handlers (N); |
| |
| begin |
| if Present (Handlers) then |
| Kill_All_Checks; |
| end if; |
| |
| Analyze_Statements (Statements (N)); |
| |
| if Present (Handlers) then |
| Analyze_Exception_Handlers (Handlers); |
| |
| elsif Present (At_End_Proc (N)) then |
| Analyze (At_End_Proc (N)); |
| end if; |
| end Analyze_Handled_Statements; |
| |
| ----------------------------- |
| -- Analyze_Raise_Statement -- |
| ----------------------------- |
| |
| procedure Analyze_Raise_Statement (N : Node_Id) is |
| Exception_Id : constant Node_Id := Name (N); |
| Exception_Name : Entity_Id := Empty; |
| P : Node_Id; |
| Nkind_P : Node_Kind; |
| |
| begin |
| Check_Unreachable_Code (N); |
| |
| -- Check exception restrictions on the original source |
| |
| if Comes_From_Source (N) then |
| Check_Restriction (No_Exceptions, N); |
| end if; |
| |
| -- Check for useless assignment to OUT or IN OUT scalar |
| -- immediately preceding the raise. Right now we only look |
| -- at assignment statements, we could do more. |
| |
| if Is_List_Member (N) then |
| declare |
| P : Node_Id; |
| L : Node_Id; |
| |
| begin |
| P := Prev (N); |
| |
| if Present (P) |
| and then Nkind (P) = N_Assignment_Statement |
| then |
| L := Name (P); |
| |
| if Is_Scalar_Type (Etype (L)) |
| and then Is_Entity_Name (L) |
| and then Is_Formal (Entity (L)) |
| then |
| Error_Msg_N |
| ("?assignment to pass-by-copy formal may have no effect", |
| P); |
| Error_Msg_N |
| ("\?RAISE statement is abnormal return" & |
| " ('R'M 6.4.1(17))", P); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Reraise statement |
| |
| if No (Exception_Id) then |
| |
| P := Parent (N); |
| Nkind_P := Nkind (P); |
| |
| while Nkind_P /= N_Exception_Handler |
| and then Nkind_P /= N_Subprogram_Body |
| and then Nkind_P /= N_Package_Body |
| and then Nkind_P /= N_Task_Body |
| and then Nkind_P /= N_Entry_Body |
| loop |
| P := Parent (P); |
| Nkind_P := Nkind (P); |
| end loop; |
| |
| if Nkind (P) /= N_Exception_Handler then |
| Error_Msg_N |
| ("reraise statement must appear directly in a handler", N); |
| end if; |
| |
| -- Normal case with exception id present |
| |
| else |
| Analyze (Exception_Id); |
| |
| if Is_Entity_Name (Exception_Id) then |
| Exception_Name := Entity (Exception_Id); |
| end if; |
| |
| if No (Exception_Name) |
| or else Ekind (Exception_Name) /= E_Exception |
| then |
| Error_Msg_N |
| ("exception name expected in raise statement", Exception_Id); |
| end if; |
| end if; |
| end Analyze_Raise_Statement; |
| |
| ----------------------------- |
| -- Analyze_Raise_xxx_Error -- |
| ----------------------------- |
| |
| -- Normally, the Etype is already set (when this node is used within |
| -- an expression, since it is copied from the node which it rewrites). |
| -- If this node is used in a statement context, then we set the type |
| -- Standard_Void_Type. This is used both by Gigi and by the front end |
| -- to distinguish the statement use and the subexpression use. |
| |
| -- The only other required processing is to take care of the Condition |
| -- field if one is present. |
| |
| procedure Analyze_Raise_xxx_Error (N : Node_Id) is |
| begin |
| if No (Etype (N)) then |
| Set_Etype (N, Standard_Void_Type); |
| end if; |
| |
| if Present (Condition (N)) then |
| Analyze_And_Resolve (Condition (N), Standard_Boolean); |
| end if; |
| |
| -- Deal with static cases in obvious manner |
| |
| if Nkind (Condition (N)) = N_Identifier then |
| if Entity (Condition (N)) = Standard_True then |
| Set_Condition (N, Empty); |
| |
| elsif Entity (Condition (N)) = Standard_False then |
| Rewrite (N, Make_Null_Statement (Sloc (N))); |
| end if; |
| end if; |
| |
| end Analyze_Raise_xxx_Error; |
| |
| ----------------------------- |
| -- Analyze_Subprogram_Info -- |
| ----------------------------- |
| |
| procedure Analyze_Subprogram_Info (N : Node_Id) is |
| begin |
| Set_Etype (N, RTE (RE_Code_Loc)); |
| end Analyze_Subprogram_Info; |
| |
| end Sem_Ch11; |
