1896 lines
64 KiB
Ada
1896 lines
64 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ C H 1 1 --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 1992-2002 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 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.
|
|
|
|
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.
|
|
|
|
-----------------------------
|
|
-- 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);
|
|
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))
|
|
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;
|
|
|
|
-- 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_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 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;
|
|
|
|
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 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 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 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;
|
|
|
|
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;
|