------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ 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 Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Util; use Exp_Util; with Hostparm; use Hostparm; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch11 is --------------------------- -- Expand_At_End_Handler -- --------------------------- -- For a handled statement sequence that has a cleanup (At_End_Proc -- field set), an exception handler of the following form is required: -- exception -- when all others => -- cleanup call -- raise; -- Note: this exception handler is treated rather specially by -- subsequent expansion in two respects: -- The normal call to Undefer_Abort is omitted -- The raise call does not do Defer_Abort -- This is because the current tasking code seems to assume that -- the call to the cleanup routine that is made from an exception -- handler for the abort signal is called with aborts deferred. -- This expansion is only done if we have front end exception handling. -- If we have back end exception handling, then the AT END handler is -- left alone, and cleanups (including the exceptional case) are handled -- by the back end. -- In the front end case, the exception handler described above handles -- the exceptional case. The AT END handler is left in the generated tree -- and the code generator (e.g. gigi) must still handle proper generation -- of cleanup calls for the non-exceptional case. procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); Loc : constant Source_Ptr := Sloc (Clean); Ohandle : Node_Id; Stmnts : List_Id; begin pragma Assert (Present (Clean)); pragma Assert (No (Exception_Handlers (HSS))); -- Don't expand if back end exception handling active if Exception_Mechanism = Back_End_Exceptions then return; end if; -- Don't expand an At End handler if we have already had configurable -- run-time violations, since likely this will just be a matter of -- generating useless cascaded messages if Configurable_Run_Time_Violations > 0 then return; end if; if Restriction_Active (No_Exception_Handlers) then return; end if; if Present (Block) then New_Scope (Block); end if; Ohandle := Make_Others_Choice (Loc); Set_All_Others (Ohandle); Stmnts := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Clean, Loc)), Make_Raise_Statement (Loc)); Set_Exception_Handlers (HSS, New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List (Ohandle), Statements => Stmnts))); Analyze_List (Stmnts, Suppress => All_Checks); Expand_Exception_Handlers (HSS); if Present (Block) then Pop_Scope; end if; end Expand_At_End_Handler; ------------------------------- -- Expand_Exception_Handlers -- ------------------------------- procedure Expand_Exception_Handlers (HSS : Node_Id) is Handlrs : constant List_Id := Exception_Handlers (HSS); Loc : Source_Ptr; Handler : Node_Id; Others_Choice : Boolean; Obj_Decl : Node_Id; procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List); -- Routine to prepend a call to the procedure referenced by Proc at -- the start of the handler code for the current Handler. ----------------------------- -- Prepend_Call_To_Handler -- ----------------------------- procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List) is Ent : constant Entity_Id := RTE (Proc); begin -- If we have no Entity, then we are probably in no run time mode -- or some weird error has occured. In either case do do nothing! if Present (Ent) then declare Call : constant Node_Id := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (Proc), Loc), Parameter_Associations => Args); begin Prepend_To (Statements (Handler), Call); Analyze (Call, Suppress => All_Checks); end; end if; end Prepend_Call_To_Handler; -- Start of processing for Expand_Exception_Handlers begin -- Loop through handlers Handler := First_Non_Pragma (Handlrs); Handler_Loop : while Present (Handler) loop Loc := Sloc (Handler); -- Remove source handler if gnat debug flag N is set if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then declare H : constant Node_Id := Handler; begin Next_Non_Pragma (Handler); Remove (H); goto Continue_Handler_Loop; end; end if; -- If an exception occurrence is present, then we must declare it -- and initialize it from the value stored in the TSD -- declare -- name : Exception_Occurrence; -- -- begin -- Save_Occurrence (name, Get_Current_Excep.all) -- ... -- end; if Present (Choice_Parameter (Handler)) then declare Cparm : constant Entity_Id := Choice_Parameter (Handler); Clc : constant Source_Ptr := Sloc (Cparm); Save : Node_Id; begin Save := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Cparm, Clc), Make_Explicit_Dereference (Loc, Make_Function_Call (Loc, Name => Make_Explicit_Dereference (Loc, New_Occurrence_Of (RTE (RE_Get_Current_Excep), Loc)))))); Mark_Rewrite_Insertion (Save); Prepend (Save, Statements (Handler)); Obj_Decl := Make_Object_Declaration (Clc, Defining_Identifier => Cparm, Object_Definition => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Clc)); Set_No_Initialization (Obj_Decl, True); Rewrite (Handler, Make_Exception_Handler (Loc, Exception_Choices => Exception_Choices (Handler), Statements => New_List ( Make_Block_Statement (Loc, Declarations => New_List (Obj_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements (Handler)))))); Analyze_List (Statements (Handler), Suppress => All_Checks); end; end if; -- The processing at this point is rather different for the -- JVM case, so we completely separate the processing. -- For the JVM case, we unconditionally call Update_Exception, -- passing a call to the intrinsic function Current_Target_Exception -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details). if Hostparm.Java_VM then declare Arg : constant Node_Id := Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Current_Target_Exception), Loc)); begin Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg)); end; -- For the normal case, we have to worry about the state of abort -- deferral. Generally, we defer abort during runtime handling of -- exceptions. When control is passed to the handler, then in the -- normal case we undefer aborts. In any case this entire handling -- is relevant only if aborts are allowed! elsif Abort_Allowed then -- There are some special cases in which we do not do the -- undefer. In particular a finalization (AT END) handler -- wants to operate with aborts still deferred. -- We also suppress the call if this is the special handler -- for Abort_Signal, since if we are aborting, we want to keep -- aborts deferred (one abort is enough thank you very much :-) -- If abort really needs to be deferred the expander must add -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select. Others_Choice := Nkind (First (Exception_Choices (Handler))) = N_Others_Choice; if (Others_Choice or else Entity (First (Exception_Choices (Handler))) /= Stand.Abort_Signal) and then not (Others_Choice and then All_Others (First (Exception_Choices (Handler)))) and then Abort_Allowed then Prepend_Call_To_Handler (RE_Abort_Undefer); end if; end if; Next_Non_Pragma (Handler); <> null; end loop Handler_Loop; -- If all handlers got removed by gnatdN, then remove the list if Debug_Flag_Dot_X and then Is_Empty_List (Exception_Handlers (HSS)) then Set_Exception_Handlers (HSS, No_List); end if; end Expand_Exception_Handlers; ------------------------------------ -- Expand_N_Exception_Declaration -- ------------------------------------ -- Generates: -- exceptE : constant String := "A.B.EXCEP"; -- static data -- except : exception_data := ( -- Handled_By_Other => False, -- Lang => 'A', -- Name_Length => exceptE'Length, -- Full_Name => exceptE'Address, -- HTable_Ptr => null, -- Import_Code => 0, -- Raise_Hook => null, -- ); -- (protecting test only needed if not at library level) -- -- exceptF : Boolean := True -- static data -- if exceptF then -- exceptF := False; -- Register_Exception (except'Unchecked_Access); -- end if; procedure Expand_N_Exception_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); L : List_Id := New_List; Flag_Id : Entity_Id; Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E'); Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); begin -- There is no expansion needed when compiling for the JVM since the -- JVM has a built-in exception mechanism. See 4jexcept.ads for details. if Hostparm.Java_VM then return; end if; -- Definition of the external name: nam : constant String := "A.B.NAME"; Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id)))); Set_Is_Statically_Allocated (Exname); -- Create the aggregate list for type Standard.Exception_Type: -- Handled_By_Other component: False Append_To (L, New_Occurrence_Of (Standard_False, Loc)); -- Lang component: 'A' Append_To (L, Make_Character_Literal (Loc, Chars => Name_uA, Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); -- Name_Length component: Nam'Length Append_To (L, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Length)); -- Full_Name component: Standard.A_Char!(Nam'Address) Append_To (L, Unchecked_Convert_To (Standard_A_Char, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address))); -- HTable_Ptr component: null Append_To (L, Make_Null (Loc)); -- Import_Code component: 0 Append_To (L, Make_Integer_Literal (Loc, 0)); -- Raise_Hook component: null Append_To (L, Make_Null (Loc)); Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); Analyze_And_Resolve (Expression (N), Etype (Id)); -- Register_Exception (except'Unchecked_Access); if not Restriction_Active (No_Exception_Handlers) and then not Restriction_Active (No_Exception_Registration) then L := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Id, Loc), Attribute_Name => Name_Unrestricted_Access))))); Set_Register_Exception_Call (Id, First (L)); if not Is_Library_Level_Entity (Id) then Flag_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'F')); Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Flag_Id, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); Set_Is_Statically_Allocated (Flag_Id); Append_To (L, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Flag_Id, Loc), Expression => New_Occurrence_Of (Standard_False, Loc))); Insert_After_And_Analyze (N, Make_Implicit_If_Statement (N, Condition => New_Occurrence_Of (Flag_Id, Loc), Then_Statements => L)); else Insert_List_After_And_Analyze (N, L); end if; end if; end Expand_N_Exception_Declaration; --------------------------------------------- -- Expand_N_Handled_Sequence_Of_Statements -- --------------------------------------------- procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is begin if Present (Exception_Handlers (N)) and then not Restriction_Active (No_Exception_Handlers) then Expand_Exception_Handlers (N); end if; -- The following code needs comments ??? if Nkind (Parent (N)) /= N_Package_Body and then Nkind (Parent (N)) /= N_Accept_Statement and then not Delay_Cleanups (Current_Scope) then Expand_Cleanup_Actions (Parent (N)); else Set_First_Real_Statement (N, First (Statements (N))); end if; end Expand_N_Handled_Sequence_Of_Statements; ------------------------------------- -- Expand_N_Raise_Constraint_Error -- ------------------------------------- -- The only processing required is to adjust the condition to deal -- with the C/Fortran boolean case. This may well not be necessary, -- as all such conditions are generated by the expander and probably -- are all standard boolean, but who knows what strange optimization -- in future may require this adjustment! procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is begin Adjust_Condition (Condition (N)); end Expand_N_Raise_Constraint_Error; ---------------------------------- -- Expand_N_Raise_Program_Error -- ---------------------------------- -- The only processing required is to adjust the condition to deal -- with the C/Fortran boolean case. This may well not be necessary, -- as all such conditions are generated by the expander and probably -- are all standard boolean, but who knows what strange optimization -- in future may require this adjustment! procedure Expand_N_Raise_Program_Error (N : Node_Id) is begin Adjust_Condition (Condition (N)); end Expand_N_Raise_Program_Error; ------------------------------ -- Expand_N_Raise_Statement -- ------------------------------ procedure Expand_N_Raise_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ehand : Node_Id; E : Entity_Id; Str : String_Id; begin -- If a string expression is present, then the raise statement is -- converted to a call: -- Raise_Exception (exception-name'Identity, string); -- and there is nothing else to do if Present (Expression (N)) then Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Name (N), Attribute_Name => Name_Identity), Expression (N)))); Analyze (N); return; end if; -- Remaining processing is for the case where no string expression -- is present. -- There is no expansion needed for statement "raise ;" when -- compiling for the JVM since the JVM has a built-in exception -- mechanism. However we need the keep the expansion for "raise;" -- statements. See 4jexcept.ads for details. if Present (Name (N)) and then Hostparm.Java_VM then return; end if; -- Don't expand a raise statement that does not come from source -- if we have already had configurable run-time violations, since -- most likely it will be junk cascaded nonsense. if Configurable_Run_Time_Violations > 0 and then not Comes_From_Source (N) then return; end if; -- Convert explicit raise of Program_Error, Constraint_Error, and -- Storage_Error into the corresponding raise (in High_Integrity_Mode -- all other raises will get normal expansion and be disallowed, -- but this is also faster in all modes). if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then if Entity (Name (N)) = Standard_Constraint_Error then Rewrite (N, Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise)); Analyze (N); return; elsif Entity (Name (N)) = Standard_Program_Error then Rewrite (N, Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); Analyze (N); return; elsif Entity (Name (N)) = Standard_Storage_Error then Rewrite (N, Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise)); Analyze (N); return; end if; end if; -- Case of name present, in this case we expand raise name to -- Raise_Exception (name'Identity, location_string); -- where location_string identifies the file/line of the raise if Present (Name (N)) then declare Id : Entity_Id := Entity (Name (N)); begin Build_Location_String (Loc); -- If the exception is a renaming, use the exception that it -- renames (which might be a predefined exception, e.g.). if Present (Renamed_Object (Id)) then Id := Renamed_Object (Id); end if; -- Build a C-compatible string in case of no exception handlers, -- since this is what the last chance handler is expecting. if Restriction_Active (No_Exception_Handlers) then -- Generate an empty message if configuration pragma -- Suppress_Exception_Locations is set for this unit. if Opt.Exception_Locations_Suppressed then Name_Len := 1; else Name_Len := Name_Len + 1; end if; Name_Buffer (Name_Len) := ASCII.NUL; end if; if Opt.Exception_Locations_Suppressed then Name_Len := 0; end if; Str := String_From_Name_Buffer; -- For VMS exceptions, convert the raise into a call to -- lib$stop so it will be handled by __gnat_error_handler. if Is_VMS_Exception (Id) then declare Excep_Image : String_Id; Cond : Node_Id; begin if Present (Interface_Name (Id)) then Excep_Image := Strval (Interface_Name (Id)); else Get_Name_String (Chars (Id)); Set_All_Upper_Case; Excep_Image := String_From_Name_Buffer; end if; if Exception_Code (Id) /= No_Uint then Cond := Make_Integer_Literal (Loc, Exception_Code (Id)); else Cond := Unchecked_Convert_To (Standard_Integer, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Import_Value), Loc), Parameter_Associations => New_List (Make_String_Literal (Loc, Strval => Excep_Image)))); end if; Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), Parameter_Associations => New_List (Cond))); Analyze_And_Resolve (Cond, Standard_Integer); end; -- Not VMS exception case, convert raise to call to the -- Raise_Exception routine. else Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Name (N), Attribute_Name => Name_Identity), Make_String_Literal (Loc, Strval => Str)))); end if; end; -- Case of no name present (reraise). We rewrite the raise to: -- Reraise_Occurrence_Always (EO); -- where EO is the current exception occurrence. If the current handler -- does not have a choice parameter specification, then we provide one. else -- Find innermost enclosing exception handler (there must be one, -- since the semantics has already verified that this raise statement -- is valid, and a raise with no arguments is only permitted in the -- context of an exception handler. Ehand := Parent (N); while Nkind (Ehand) /= N_Exception_Handler loop Ehand := Parent (Ehand); end loop; -- Make exception choice parameter if none present. Note that we do -- not need to put the entity on the entity chain, since no one will -- be referencing this entity by normal visibility methods. if No (Choice_Parameter (Ehand)) then E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); Set_Choice_Parameter (Ehand, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); Set_Scope (E, Current_Scope); end if; -- Now rewrite the raise as a call to Reraise. A special case arises -- if this raise statement occurs in the context of a handler for -- all others (i.e. an at end handler). in this case we avoid -- the call to defer abort, cleanup routines are expected to be -- called in this case with aborts deferred. declare Ech : constant Node_Id := First (Exception_Choices (Ehand)); Ent : Entity_Id; begin if Nkind (Ech) = N_Others_Choice and then All_Others (Ech) then Ent := RTE (RE_Reraise_Occurrence_No_Defer); else Ent := RTE (RE_Reraise_Occurrence_Always); end if; Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Ent, Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Choice_Parameter (Ehand), Loc)))); end; end if; Analyze (N); end Expand_N_Raise_Statement; ---------------------------------- -- Expand_N_Raise_Storage_Error -- ---------------------------------- -- The only processing required is to adjust the condition to deal -- with the C/Fortran boolean case. This may well not be necessary, -- as all such conditions are generated by the expander and probably -- are all standard boolean, but who knows what strange optimization -- in future may require this adjustment! procedure Expand_N_Raise_Storage_Error (N : Node_Id) is begin Adjust_Condition (Condition (N)); end Expand_N_Raise_Storage_Error; ------------------------------ -- Expand_N_Subprogram_Info -- ------------------------------ procedure Expand_N_Subprogram_Info (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); begin -- For now, we replace an Expand_N_Subprogram_Info node with an -- attribute reference that gives the address of the procedure. -- This is because gigi does not yet recognize this node, and -- for the initial targets, this is the right value anyway. Rewrite (N, Make_Attribute_Reference (Loc, Prefix => Identifier (N), Attribute_Name => Name_Code_Address)); Analyze_And_Resolve (N, RTE (RE_Code_Loc)); end Expand_N_Subprogram_Info; ---------------------- -- Is_Non_Ada_Error -- ---------------------- function Is_Non_Ada_Error (E : Entity_Id) return Boolean is begin if not OpenVMS_On_Target then return False; end if; Get_Name_String (Chars (E)); -- Note: it is a little irregular for the body of exp_ch11 to know -- the details of the encoding scheme for names, but on the other -- hand, gigi knows them, and this is for gigi's benefit anyway! if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then return False; end if; return True; end Is_Non_Ada_Error; end Exp_Ch11;