diff options
Diffstat (limited to 'gcc/ada/exp_ch11.adb')
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 1824 |
1 files changed, 1824 insertions, 0 deletions
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb new file mode 100644 index 00000000000..62a4f6fd3e6 --- /dev/null +++ b/gcc/ada/exp_ch11.adb @@ -0,0 +1,1824 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 1 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.117 $ +-- -- +-- Copyright (C) 1992-2001 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Exp_Ch7; use Exp_Ch7; +with Exp_Util; use Exp_Util; +with Hostparm; use Hostparm; +with Inline; use Inline; +with Lib; use Lib; +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 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 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; +with Uname; use Uname; + +package body Exp_Ch11 is + + SD_List : List_Id; + -- This list gathers the values SDn'Unrestricted_Access used to + -- construct the unit exception table. It is set to Empty_List if + -- there are no subprogram descriptors. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Exception_Handler_Tables (HSS : Node_Id); + -- Subsidiary procedure called by Expand_Exception_Handlers if zero + -- cost exception handling is installed for this target. Replaces the + -- exception handler structure with appropriate labeled code and tables + -- that allow the zero cost exception handling circuits to find the + -- correct handler (see unit Ada.Exceptions for details). + + procedure Generate_Subprogram_Descriptor + (N : Node_Id; + Loc : Source_Ptr; + Spec : Entity_Id; + Slist : List_Id); + -- Procedure called to generate a subprogram descriptor. N is the + -- subprogram body node or, in the case of an imported subprogram, is + -- Empty, and Spec is the entity of the sunprogram. For details of the + -- required structure, see package System.Exceptions. The generated + -- subprogram descriptor is appended to Slist. Loc provides the + -- source location to be used for the generated descriptor. + + --------------------------- + -- 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. + + 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))); + + if Restrictions (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_Handler_Tables -- + ------------------------------------- + + -- See Ada.Exceptions specification for full details of the data + -- structures that we need to construct here. As an example of the + -- transformation that is required, given the structure: + + -- declare + -- {declarations} + -- .. + -- begin + -- {statements-1} + -- ... + -- exception + -- when a | b => + -- {statements-2} + -- ... + -- when others => + -- {statements-3} + -- ... + -- end; + + -- We transform this into: + + -- declare + -- {declarations} + -- ... + -- L1 : label; + -- L2 : label; + -- L3 : label; + -- L4 : Label; + -- L5 : label; + + -- begin + -- <<L1>> + -- {statements-1} + -- <<L2>> + + -- exception + + -- when a | b => + -- <<L3>> + -- {statements-2} + + -- HR2 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => a'Identity, + -- Handler => L5'Address); + + -- HR3 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => b'Identity, + -- Handler => L4'Address); + + -- when others => + -- <<L4>> + -- {statements-3} + + -- HR1 : constant Handler_Record := ( + -- Lo => L1'Address, + -- Hi => L2'Address, + -- Id => Others_Id, + -- Handler => L4'Address); + -- end; + + -- The exception handlers in the transformed version are marked with the + -- Zero_Cost_Handling flag set, and all gigi does in this case is simply + -- to put the handler code somewhere. It can optionally be put inline + -- between the goto L3 and the label <<L3>> (which is why we generate + -- that goto in the first place). + + procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is + Loc : constant Source_Ptr := Sloc (HSS); + Handlrs : constant List_Id := Exception_Handlers (HSS); + Stms : constant List_Id := Statements (HSS); + Handler : Node_Id; + + Hlist : List_Id; + -- This is the list to which handlers are to be appended. It is + -- either the list for the enclosing subprogram, or the enclosing + -- selective accept statement (which will turn into a subprogram + -- during expansion later on). + + L1 : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + L2 : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Lnn : Entity_Id; + Choice : Node_Id; + E_Id : Node_Id; + HR_Ent : Node_Id; + HL_Ref : Node_Id; + Item : Node_Id; + + Subp_Entity : Entity_Id; + -- This is the entity for the subprogram (or library level package) + -- to which the handler record is to be attached for later reference + -- in a subprogram descriptor for this entity. + + procedure Append_To_Stms (N : Node_Id); + -- Append given statement to the end of the statements of the + -- handled sequence of statements and analyze it in place. + + function Inside_Selective_Accept return Boolean; + -- This function is called if we are inside the scope of an entry + -- or task. It checks if the handler is appearing in the context + -- of a selective accept statement. If so, Hlist is set to + -- temporarily park the handlers in the N_Accept_Alternative. + -- node. They will subsequently be moved to the procedure entity + -- for the procedure built for this alternative. The statements that + -- follow the Accept within the alternative are not inside the Accept + -- for purposes of this test, and handlers that may appear within + -- them belong in the enclosing task procedure. + + procedure Set_Hlist; + -- Sets the handler list corresponding to Subp_Entity + + -------------------- + -- Append_To_Stms -- + -------------------- + + procedure Append_To_Stms (N : Node_Id) is + begin + Insert_After_And_Analyze (Last (Stms), N); + Set_Exception_Junk (N); + end Append_To_Stms; + + ----------------------------- + -- Inside_Selective_Accept -- + ----------------------------- + + function Inside_Selective_Accept return Boolean is + Parnt : Node_Id; + Curr : Node_Id := HSS; + + begin + Parnt := Parent (HSS); + while Nkind (Parnt) /= N_Compilation_Unit loop + if Nkind (Parnt) = N_Accept_Alternative + and then Curr = Accept_Statement (Parnt) + then + if Present (Accept_Handler_Records (Parnt)) then + Hlist := Accept_Handler_Records (Parnt); + else + Hlist := New_List; + Set_Accept_Handler_Records (Parnt, Hlist); + end if; + + return True; + else + Curr := Parnt; + Parnt := Parent (Parnt); + end if; + end loop; + + return False; + end Inside_Selective_Accept; + + --------------- + -- Set_Hlist -- + --------------- + + procedure Set_Hlist is + begin + -- Never try to inline a subprogram with exception handlers + + Set_Is_Inlined (Subp_Entity, False); + + if Present (Subp_Entity) + and then Present (Handler_Records (Subp_Entity)) + then + Hlist := Handler_Records (Subp_Entity); + else + Hlist := New_List; + Set_Handler_Records (Subp_Entity, Hlist); + end if; + end Set_Hlist; + + -- Start of processing for Expand_Exception_Handler_Tables + + begin + -- Nothing to do if this handler has already been processed + + if Zero_Cost_Handling (HSS) then + return; + end if; + + Set_Zero_Cost_Handling (HSS); + + -- Find the parent subprogram or package scope containing this + -- exception frame. This should always find a real package or + -- subprogram. If it does not it will stop at Standard, but + -- this cannot legitimately occur. + + -- We only stop at library level packages, for inner packages + -- we always attach handlers to the containing procedure. + + Subp_Entity := Current_Scope; + Scope_Loop : loop + + -- Never need tables expanded inside a generic template + + if Is_Generic_Unit (Subp_Entity) then + return; + + -- Stop if we reached containing subprogram. Go to protected + -- subprogram if there is one defined. + + elsif Ekind (Subp_Entity) = E_Function + or else Ekind (Subp_Entity) = E_Procedure + then + if Present (Protected_Body_Subprogram (Subp_Entity)) then + Subp_Entity := Protected_Body_Subprogram (Subp_Entity); + end if; + + Set_Hlist; + exit Scope_Loop; + + -- Case of within an entry + + elsif Is_Entry (Subp_Entity) then + + -- Protected entry, use corresponding body subprogram + + if Present (Protected_Body_Subprogram (Subp_Entity)) then + Subp_Entity := Protected_Body_Subprogram (Subp_Entity); + Set_Hlist; + exit Scope_Loop; + + -- Check if we are within a selective accept alternative + + elsif Inside_Selective_Accept then + + -- As a side effect, Inside_Selective_Accept set Hlist, + -- in much the same manner as Set_Hlist, except that + -- the list involved was the one for the selective accept. + + exit Scope_Loop; + end if; + + -- Case of within library level package + + elsif Ekind (Subp_Entity) = E_Package + and then Is_Compilation_Unit (Subp_Entity) + then + if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then + Subp_Entity := Body_Entity (Subp_Entity); + end if; + + Set_Hlist; + exit Scope_Loop; + + -- Task type case + + elsif Ekind (Subp_Entity) = E_Task_Type then + + -- Check if we are within a selective accept alternative + + if Inside_Selective_Accept then + + -- As a side effect, Inside_Selective_Accept set Hlist, + -- in much the same manner as Set_Hlist, except that the + -- list involved was the one for the selective accept. + + exit Scope_Loop; + + -- Stop if we reached task type with task body procedure, + -- use the task body procedure. + + elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then + Subp_Entity := Get_Task_Body_Procedure (Subp_Entity); + Set_Hlist; + exit Scope_Loop; + end if; + end if; + + -- If we fall through, keep looking + + Subp_Entity := Scope (Subp_Entity); + end loop Scope_Loop; + + pragma Assert (Subp_Entity /= Standard_Standard); + + -- Analyze standard labels + + Analyze_Label_Entity (L1); + Analyze_Label_Entity (L2); + + Insert_Before_And_Analyze (First (Stms), + Make_Label (Loc, + Identifier => New_Occurrence_Of (L1, Loc))); + Set_Exception_Junk (First (Stms)); + + Append_To_Stms ( + Make_Label (Loc, + Identifier => New_Occurrence_Of (L2, Loc))); + + -- Loop through exception handlers + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + Set_Zero_Cost_Handling (Handler); + + -- Add label at start of handler, and goto at the end + + Lnn := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Analyze_Label_Entity (Lnn); + + Item := + Make_Label (Loc, + Identifier => New_Occurrence_Of (Lnn, Loc)); + Set_Exception_Junk (Item); + Insert_Before_And_Analyze (First (Statements (Handler)), Item); + + -- Loop through choices + + Choice := First (Exception_Choices (Handler)); + while Present (Choice) loop + + -- Others (or all others) choice + + if Nkind (Choice) = N_Others_Choice then + if All_Others (Choice) then + E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc); + else + E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc); + end if; + + -- Special case of VMS_Exception. Not clear what we will do + -- eventually here if and when we implement zero cost exceptions + -- on VMS. But at least for now, don't blow up trying to take + -- a garbage code address for such an exception. + + elsif Is_VMS_Exception (Entity (Choice)) then + E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc); + + -- Normal case of specific exception choice + + else + E_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Entity (Choice), Loc), + Attribute_Name => Name_Identity); + end if; + + HR_Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('H')); + + HL_Ref := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (HR_Ent, Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- Now we need to add the entry for the new handler record to + -- the list of handler records for the current subprogram. + + -- Normally we end up generating the handler records in exactly + -- the right order. Here right order means innermost first, + -- since the table will be searched sequentially. Since we + -- generally expand from outside to inside, the order is just + -- what we want, and we need to append the new entry to the + -- end of the list. + + -- However, there are exceptions, notably in the case where + -- a generic body is inserted later on. See for example the + -- case of ACVC test C37213J, which has the following form: + + -- generic package x ... end x; + -- package body x is + -- begin + -- ... + -- exception (1) + -- ... + -- end x; + + -- ... + + -- declare + -- package q is new x; + -- begin + -- ... + -- exception (2) + -- ... + -- end; + + -- In this case, we will expand exception handler (2) first, + -- since the expansion of (1) is delayed till later when the + -- generic body is inserted. But (1) belongs before (2) in + -- the chain. + + -- Note that scopes are not totally ordered, because two + -- scopes can be in parallel blocks, so that it does not + -- matter what order these entries appear in. An ordering + -- relation exists if one scope is inside another, and what + -- we really want is some partial ordering. + + -- A simple, not very efficient, but adequate algorithm to + -- achieve this partial ordering is to search the list for + -- the first entry containing the given scope, and put the + -- new entry just before it. + + declare + New_Scop : constant Entity_Id := Current_Scope; + Ent : Node_Id; + + begin + Ent := First (Hlist); + loop + -- If all searched, then we can just put the new + -- entry at the end of the list (it actually does + -- not matter where we put it in this case). + + if No (Ent) then + Append_To (Hlist, HL_Ref); + exit; + + -- If the current scope is within the scope of the + -- entry then insert the entry before to retain the + -- proper order as per above discussion. + + -- Note that for equal entries, we just keep going, + -- which is fine, the entry will end up at the end + -- of the list where it belongs. + + elsif Scope_Within + (New_Scop, Scope (Entity (Prefix (Ent)))) + then + Insert_Before (Ent, HL_Ref); + exit; + + -- Otherwise keep looking + + else + Next (Ent); + end if; + end loop; + end; + + Item := + Make_Object_Declaration (Loc, + Defining_Identifier => HR_Ent, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Handler_Record), Loc), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, -- Lo + Prefix => New_Occurrence_Of (L1, Loc), + Attribute_Name => Name_Address), + + Make_Attribute_Reference (Loc, -- Hi + Prefix => New_Occurrence_Of (L2, Loc), + Attribute_Name => Name_Address), + + E_Id, -- Id + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler + Attribute_Name => Name_Address)))); + + Set_Handler_List_Entry (Item, HL_Ref); + Set_Exception_Junk (Item); + Insert_After_And_Analyze (Last (Statements (Handler)), Item); + Set_Is_Statically_Allocated (HR_Ent); + + -- If this is a late insertion (from body instance) it is being + -- inserted in the component list of an already analyzed aggre- + -- gate, and must be analyzed explicitly. + + Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr)); + + Next (Choice); + end loop; + + Next_Non_Pragma (Handler); + end loop; + end Expand_Exception_Handler_Tables; + + ------------------------------- + -- 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. + + procedure Prepend_Call_To_Handler + (Proc : RE_Id; + Args : List_Id := No_List) + is + 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 Prepend_Call_To_Handler; + + -- Start of processing for Expand_Exception_Handlers + + begin + -- Loop through handlers + + Handler := First_Non_Pragma (Handlrs); + while Present (Handler) loop + Loc := Sloc (Handler); + + -- 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 : 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); + end loop; + + -- The last step for expanding exception handlers is to expand the + -- exception tables if zero cost exception handling is active. + + if Exception_Mechanism = Front_End_ZCX then + Expand_Exception_Handler_Tables (HSS); + 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); + + -- (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, Name_uA, Get_Char_Code ('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)); + + Set_Expression (N, Make_Aggregate (Loc, Expressions => L)); + Analyze_And_Resolve (Expression (N), Etype (Id)); + + -- Register_Exception (except'Unchecked_Access); + + if not Restrictions (No_Exception_Handlers) 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)) 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 + -- 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; + + -- Convert explicit raise of Program_Error, Constraint_Error, and + -- Storage_Error into the corresponding raise node (in No_Run_Time + -- 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_Program_Error then + Rewrite (N, Make_Raise_Program_Error (Loc)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Constraint_Error then + Rewrite (N, Make_Raise_Constraint_Error (Loc)); + Analyze (N); + return; + + elsif Entity (Name (N)) = Standard_Storage_Error then + Rewrite (N, Make_Raise_Storage_Error (Loc)); + 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); + + -- Build a C compatible string in case of no exception handlers, + -- since this is what the last chance handler is expecting. + + if Restrictions (No_Exception_Handlers) then + -- Generate a C null message when Global_Discard_Names is True + -- or when Debug_Flag_NN is set. + + if Global_Discard_Names or else Debug_Flag_NN then + Name_Buffer (1) := ASCII.NUL; + Name_Len := 1; + else + Name_Len := Name_Len + 1; + end if; + + -- Do not generate the message when Global_Discard_Names is True + -- or when Debug_Flag_NN is set. + + elsif Global_Discard_Names or else Debug_Flag_NN 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; + + ------------------------------------ + -- Generate_Subprogram_Descriptor -- + ------------------------------------ + + procedure Generate_Subprogram_Descriptor + (N : Node_Id; + Loc : Source_Ptr; + Spec : Entity_Id; + Slist : List_Id) + is + Code : Node_Id; + Ent : Entity_Id; + Decl : Node_Id; + Dtyp : Entity_Id; + Numh : Nat; + Sdes : Node_Id; + Hrc : List_Id; + + begin + if Exception_Mechanism /= Front_End_ZCX then + return; + end if; + + -- Suppress descriptor if we are not generating code. This happens + -- in the case of a -gnatc -gnatt compilation where we force generics + -- to be generated, but we still don't want exception tables. + + if Operating_Mode /= Generate_Code then + return; + end if; + + -- Suppress descriptor if we are in No_Exceptions restrictions mode, + -- since we can never propagate exceptions in any case in this mode. + -- The same consideration applies for No_Exception_Handlers (which + -- is also set in No_Run_Time mode). + + if Restrictions (No_Exceptions) + or Restrictions (No_Exception_Handlers) + then + return; + end if; + + -- Suppress descriptor if we are inside a generic. There are two + -- ways that we can tell that, depending on what is going on. If + -- we are actually inside the processing for a generic right now, + -- then Expander_Active will be reset. If we are outside the + -- generic, then we will see the generic entity. + + if not Expander_Active then + return; + end if; + + -- Suppress descriptor is subprogram is marked as eliminated, for + -- example if this is a subprogram created to analyze a default + -- expression with potential side effects. Ditto if it is nested + -- within an eliminated subprogram, for example a cleanup action. + + declare + Scop : Entity_Id; + + begin + Scop := Spec; + while Scop /= Standard_Standard loop + if Ekind (Scop) = E_Generic_Procedure + or else + Ekind (Scop) = E_Generic_Function + or else + Ekind (Scop) = E_Generic_Package + or else + Is_Eliminated (Scop) + then + return; + end if; + + Scop := Scope (Scop); + end loop; + end; + + -- Suppress descriptor for original protected subprogram (we will + -- be called again later to generate the descriptor for the actual + -- protected body subprogram.) This does not apply to barrier + -- functions which are there own protected subprogram. + + if Is_Subprogram (Spec) + and then Present (Protected_Body_Subprogram (Spec)) + and then Protected_Body_Subprogram (Spec) /= Spec + then + return; + end if; + + -- Suppress descriptors for packages unless they have at least one + -- handler. The binder will generate the dummy (no handler) descriptors + -- for elaboration procedures. We can't do it here, because we don't + -- know if an elaboration routine does in fact exist. + + -- If there is at least one handler for the package spec or body + -- then most certainly an elaboration routine must exist, so we + -- can safely reference it. + + if (Nkind (N) = N_Package_Declaration + or else + Nkind (N) = N_Package_Body) + and then No (Handler_Records (Spec)) + then + return; + end if; + + -- Suppress all subprogram descriptors for the file System.Exceptions. + -- We similarly suppress subprogram descriptors for Ada.Exceptions. + -- These are all init_proc's for types which cannot raise exceptions. + -- The reason this is done is that otherwise we get embarassing + -- elaboration dependencies. + + Get_Name_String (Unit_File_Name (Current_Sem_Unit)); + + if Name_Buffer (1 .. 12) = "s-except.ads" + or else + Name_Buffer (1 .. 12) = "a-except.ads" + then + return; + end if; + + -- Similarly, we need to suppress entries for System.Standard_Library, + -- since otherwise we get elaboration circularities. Again, this would + -- better be done with a Suppress_Initialization pragma :-) + + if Name_Buffer (1 .. 11) = "s-stalib.ad" then + return; + end if; + + -- For now, also suppress entries for s-stoele because we have + -- some kind of unexplained error there ??? + + if Name_Buffer (1 .. 11) = "s-stoele.ad" then + return; + end if; + + -- And also for g-htable, because it cannot raise exceptions, + -- and generates some kind of elaboration order problem. + + if Name_Buffer (1 .. 11) = "g-htable.ad" then + return; + end if; + + -- Suppress subprogram descriptor if already generated. This happens + -- in the case of late generation from Delay_Subprogram_Descriptors + -- beging set (where there is more than one instantiation in the list) + + if Has_Subprogram_Descriptor (Spec) then + return; + else + Set_Has_Subprogram_Descriptor (Spec); + end if; + + -- Never generate descriptors for inlined bodies + + if Analyzing_Inlined_Bodies then + return; + end if; + + -- Here we definitely are going to generate a subprogram descriptor + + declare + Hnum : Nat := Homonym_Number (Spec); + + begin + if Hnum = 1 then + Hnum := 0; + end if; + + Ent := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Spec), "SD", Hnum)); + end; + + if No (Handler_Records (Spec)) then + Hrc := Empty_List; + Numh := 0; + else + Hrc := Handler_Records (Spec); + Numh := List_Length (Hrc); + end if; + + New_Scope (Spec); + + -- We need a static subtype for the declaration of the subprogram + -- descriptor. For the case of 0-3 handlers we can use one of the + -- predefined subtypes in System.Exceptions. For more handlers, + -- we build our own subtype here. + + case Numh is + when 0 => + Dtyp := RTE (RE_Subprogram_Descriptor_0); + + when 1 => + Dtyp := RTE (RE_Subprogram_Descriptor_1); + + when 2 => + Dtyp := RTE (RE_Subprogram_Descriptor_2); + + when 3 => + Dtyp := RTE (RE_Subprogram_Descriptor_3); + + when others => + Dtyp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + -- Set the constructed type as global, since we wil be + -- referencing the object that is of this type globally + + Set_Is_Statically_Allocated (Dtyp); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Dtyp, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Numh))))); + + Append (Decl, Slist); + + -- We analyze the descriptor for the subprogram and package + -- case, but not for the imported subprogram case (it will + -- be analyzed when the freeze entity actions are analyzed. + + if Present (N) then + Analyze (Decl); + end if; + + Set_Exception_Junk (Decl); + end case; + + -- Prepare the code address entry for the table entry. For the normal + -- case of being within a procedure, this is simply: + + -- P'Code_Address + + -- where P is the procedure, but for the package case, it is + + -- P'Elab_Body'Code_Address + -- P'Elab_Spec'Code_Address + + -- for the body and spec respectively. Note that we do our own + -- analysis of these attribute references, because we know in this + -- case that the prefix of ELab_Body/Spec is a visible package, + -- which can be referenced directly instead of using the general + -- case expansion for these attributes. + + if Ekind (Spec) = E_Package then + Code := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec, Loc), + Attribute_Name => Name_Elab_Spec); + Set_Etype (Code, Standard_Void_Type); + Set_Analyzed (Code); + + elsif Ekind (Spec) = E_Package_Body then + Code := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc), + Attribute_Name => Name_Elab_Body); + Set_Etype (Code, Standard_Void_Type); + Set_Analyzed (Code); + + else + Code := New_Occurrence_Of (Spec, Loc); + end if; + + Code := + Make_Attribute_Reference (Loc, + Prefix => Code, + Attribute_Name => Name_Code_Address); + + Set_Etype (Code, RTE (RE_Address)); + Set_Analyzed (Code); + + -- Now we can build the subprogram descriptor + + Sdes := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Dtyp, Loc), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, Numh), -- Num_Handlers + + Code, -- Code + +-- temp code ??? + +-- Make_Subprogram_Info (Loc, -- Subprogram_Info +-- Identifier => +-- New_Occurrence_Of (Spec, Loc)), + + New_Copy_Tree (Code), + + Make_Aggregate (Loc, -- Handler_Records + Expressions => Hrc)))); + + Set_Exception_Junk (Sdes); + Set_Is_Subprogram_Descriptor (Sdes); + + Append (Sdes, Slist); + + -- We analyze the descriptor for the subprogram and package case, + -- but not for the imported subprogram case (it will be analyzed + -- when the freeze entity actions are analyzed. + + if Present (N) then + Analyze (Sdes); + end if; + + -- We can now pop the scope used for analyzing the descriptor + + Pop_Scope; + + -- We need to set the descriptor as statically allocated, since + -- it will be referenced from the unit exception table. + + Set_Is_Statically_Allocated (Ent); + + -- Append the resulting descriptor to the list. We do this only + -- if we are in the main unit. You might think that we could + -- simply skip generating the descriptors completely if we are + -- not in the main unit, but in fact this is not the case, since + -- we have problems with inconsistent serial numbers for internal + -- names if we do this. + + if In_Extended_Main_Code_Unit (Spec) then + Append_To (SD_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + Unit_Exception_Table_Present := True; + end if; + + end Generate_Subprogram_Descriptor; + + ------------------------------------------------------------ + -- Generate_Subprogram_Descriptor_For_Imported_Subprogram -- + ------------------------------------------------------------ + + procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram + (Spec : Entity_Id; + Slist : List_Id) + is + begin + Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist); + end Generate_Subprogram_Descriptor_For_Imported_Subprogram; + + ------------------------------------------------ + -- Generate_Subprogram_Descriptor_For_Package -- + ------------------------------------------------ + + procedure Generate_Subprogram_Descriptor_For_Package + (N : Node_Id; + Spec : Entity_Id) + is + Adecl : Node_Id; + + begin + Adecl := Aux_Decls_Node (Parent (N)); + + if No (Actions (Adecl)) then + Set_Actions (Adecl, New_List); + end if; + + Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl)); + end Generate_Subprogram_Descriptor_For_Package; + + --------------------------------------------------- + -- Generate_Subprogram_Descriptor_For_Subprogram -- + --------------------------------------------------- + + procedure Generate_Subprogram_Descriptor_For_Subprogram + (N : Node_Id; + Spec : Entity_Id) + is + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + if No (Exception_Handlers (HSS)) then + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (HSS)); + else + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (Last (Exception_Handlers (HSS)))); + end if; + end Generate_Subprogram_Descriptor_For_Subprogram; + + ----------------------------------- + -- Generate_Unit_Exception_Table -- + ----------------------------------- + + -- The only remaining thing to generate here is to generate the + -- reference to the subprogram descriptor chain. See Ada.Exceptions + -- for details of required data structures. + + procedure Generate_Unit_Exception_Table is + Loc : constant Source_Ptr := No_Location; + Num : Nat; + Decl : Node_Id; + Ent : Entity_Id; + Next_Ent : Entity_Id; + Stent : Entity_Id; + + begin + -- Nothing to be done if zero length exceptions not active + + if Exception_Mechanism /= Front_End_ZCX then + return; + end if; + + -- Remove any entries from SD_List that correspond to eliminated + -- subprograms. + + Ent := First (SD_List); + while Present (Ent) loop + Next_Ent := Next (Ent); + if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then + Remove (Ent); -- After this, there is no Next (Ent) anymore + end if; + + Ent := Next_Ent; + end loop; + + -- Nothing to do if no unit exception table present. + -- An empty table can result from subprogram elimination, + -- in such a case, eliminate the exception table itself. + + if Is_Empty_List (SD_List) then + Unit_Exception_Table_Present := False; + return; + end if; + + -- Do not generate table in a generic + + if Inside_A_Generic then + return; + end if; + + -- Generate the unit exception table + + -- subtype Tnn is Subprogram_Descriptors_Record (Num); + -- __gnat_unitname__SDP : aliased constant Tnn := + -- Num, + -- (sub1'unrestricted_access, + -- sub2'unrestricted_access, + -- ... + -- subNum'unrestricted_access)); + + Num := List_Length (SD_List); + + Stent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + Insert_Library_Level_Action ( + Make_Subtype_Declaration (Loc, + Defining_Identifier => Stent, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Subprogram_Descriptors_Record), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num)))))); + + Set_Is_Statically_Allocated (Stent); + + Get_External_Unit_Name_String (Unit_Name (Main_Unit)); + Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. 7) := "__gnat_"; + Name_Len := Name_Len + 7; + Add_Str_To_Name_Buffer ("__SDP"); + + Ent := + Make_Defining_Identifier (Loc, + Chars => Name_Find); + + Get_Name_String (Chars (Ent)); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Stent, Loc), + Constant_Present => True, + Aliased_Present => True, + Expression => + Make_Aggregate (Loc, + New_List ( + Make_Integer_Literal (Loc, List_Length (SD_List)), + + Make_Aggregate (Loc, + Expressions => SD_List)))); + + Insert_Library_Level_Action (Decl); + + Set_Is_Exported (Ent, True); + Set_Is_Public (Ent, True); + Set_Is_Statically_Allocated (Ent, True); + + Get_Name_String (Chars (Ent)); + Set_Interface_Name (Ent, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + end Generate_Unit_Exception_Table; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SD_List := Empty_List; + end Initialize; + + ---------------------- + -- 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; + + ---------------------------- + -- Remove_Handler_Entries -- + ---------------------------- + + procedure Remove_Handler_Entries (N : Node_Id) is + function Check_Handler_Entry (N : Node_Id) return Traverse_Result; + -- This function checks one node for a possible reference to a + -- handler entry that must be deleted. it always returns OK. + + function Remove_All_Handler_Entries is new + Traverse_Func (Check_Handler_Entry); + -- This defines the traversal operation + + Discard : Traverse_Result; + + function Check_Handler_Entry (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Object_Declaration then + + if Present (Handler_List_Entry (N)) then + Remove (Handler_List_Entry (N)); + Delete_Tree (Handler_List_Entry (N)); + Set_Handler_List_Entry (N, Empty); + + elsif Is_Subprogram_Descriptor (N) then + declare + SDN : Node_Id; + + begin + SDN := First (SD_List); + while Present (SDN) loop + if Defining_Identifier (N) = Entity (Prefix (SDN)) then + Remove (SDN); + Delete_Tree (SDN); + exit; + end if; + + Next (SDN); + end loop; + end; + end if; + end if; + + return OK; + end Check_Handler_Entry; + + -- Start of processing for Remove_Handler_Entries + + begin + if Exception_Mechanism = Front_End_ZCX then + Discard := Remove_All_Handler_Entries (N); + end if; + end Remove_Handler_Entries; + +end Exp_Ch11; |