| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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); |
| |
| <<Continue_Handler_Loop>> |
| 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 <exception>;" 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; |
