diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_ch11.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_ch11.adb | 826 |
1 files changed, 826 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_ch11.adb b/gcc-4.2.1/gcc/ada/exp_ch11.adb new file mode 100644 index 000000000..56c3095b2 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/exp_ch11.adb @@ -0,0 +1,826 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |