diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/sem_ch11.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/sem_ch11.adb | 499 |
1 files changed, 0 insertions, 499 deletions
diff --git a/gcc-4.2.1/gcc/ada/sem_ch11.adb b/gcc-4.2.1/gcc/ada/sem_ch11.adb deleted file mode 100644 index 978c7e38e..000000000 --- a/gcc-4.2.1/gcc/ada/sem_ch11.adb +++ /dev/null @@ -1,499 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S E M _ C H 1 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, 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 Rident; use Rident; -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_Version = 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 then - Check_Restriction (No_Obsolescent_Features, Id); - - if 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; - 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 may result in 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; - - if Present (Expression (N)) then - Analyze_And_Resolve (Expression (N), Standard_String); - 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; |