diff options
Diffstat (limited to 'gcc/ada/exp_ch11.adb')
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 1156 |
1 files changed, 1 insertions, 1155 deletions
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index d144107b813..ec6b9589286 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -32,8 +32,6 @@ 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; @@ -42,7 +40,6 @@ with Rtsfind; use Rtsfind; with Restrict; use Restrict; with Rident; use Rident; 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; @@ -54,38 +51,9 @@ 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 -- --------------------------- @@ -130,7 +98,7 @@ package body Exp_Ch11 is -- Don't expand if back end exception handling active - if Exception_Mechanism = Back_End_ZCX_Exceptions then + if Exception_Mechanism = Back_End_Exceptions then return; end if; @@ -172,498 +140,6 @@ package body Exp_Ch11 is 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 -- ------------------------------- @@ -850,13 +326,6 @@ package body Exp_Ch11 is 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; ------------------------------------ @@ -1331,574 +800,6 @@ package body Exp_Ch11 is 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 Restriction_Active (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 Restriction_Active (No_Exceptions) - or Restriction_Active (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 Restriction_Active (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 Restriction_Active (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 Restriction_Active (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 -- ---------------------- @@ -1922,59 +823,4 @@ package body Exp_Ch11 is 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; |