| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 1 1 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2003 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. -- |
| -- 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 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. |
| |
| -- 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_ZCX_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 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. |
| |
| ----------------------------- |
| -- 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; |
| |
| -- 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_Exceptions 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, |
| -- 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, 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)); |
| |
| -- 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 Restrictions (No_Exception_Handlers) |
| and then not Restrictions (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 Restrictions (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 |
| -- 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 Restrictions (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; |
| |
| ------------------------------------ |
| -- 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_Exceptions then |
| return; |
| end if; |
| |
| if Restrictions (No_Exception_Handlers) 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 High_Integrity_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 Is_Generic_Unit (Scop) 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 procs 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 will 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 |
| -- If N is empty with prior errors, ignore |
| |
| if Total_Errors_Detected /= 0 and then No (N) then |
| return; |
| end if; |
| |
| -- Do not generate if no exceptions |
| |
| if Restrictions (No_Exception_Handlers) then |
| return; |
| end if; |
| |
| -- Otherwise generate descriptor |
| |
| 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 |
| begin |
| -- If we have no subprogram body and prior errors, ignore |
| |
| if Total_Errors_Detected /= 0 and then No (N) then |
| return; |
| end if; |
| |
| -- Do not generate if no exceptions |
| |
| if Restrictions (No_Exception_Handlers) then |
| return; |
| end if; |
| |
| -- Else generate descriptor |
| |
| declare |
| 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; |
| 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_Exceptions then |
| return; |
| end if; |
| |
| -- Nothing to do if no exceptions |
| |
| if Restrictions (No_Exception_Handlers) 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; |
| pragma Warnings (Off, Discard); |
| |
| 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_Exceptions then |
| Discard := Remove_All_Handler_Entries (N); |
| end if; |
| end Remove_Handler_Entries; |
| |
| end Exp_Ch11; |
