MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
1b096a0a0a
8sa1-gcc/gcc/ada/exp_ch11.adb
Arnaud Charlet 6e937c1c5c [multiple changes] 
2004-02-02  Vincent Celier  <celier@gnat.com>

	* gprcmd.adb (Check_Args): If condition is false, print the invoked
	comment before the usage.
	Gprcmd: Fail when command is not recognized.
	(Usage): Document command "prefix"

	* g-md5.adb (Digest): Process last block.
	(Update): Do not process last block. Store remaining characters and
	length in Context.

	* g-md5.ads (Update): Document that several call to update are
	equivalent to one call with the concatenated string.
	(Context): Add fields to allow new Update behaviour.

	* fname-uf.ads/adb (Get_File_Name): New Boolean parameter May_Fail,
	defaulted to False.
	When May_Fail is True and no existing file can be found, return No_File.

	* 6vcstrea.adb: Inlined functions are now wrappers to implementation
	functions.

	* lib-writ.adb (Write_With_Lines): When body file does not exist, use
	spec file name instead on the W line.

2004-02-02  Robert Dewar  <dewar@gnat.com>

	* ali.adb: Read and acquire info from new format restrictions lines

	* bcheck.adb: Add circuits for checking restrictions with parameters

	* bindgen.adb: Output dummy restrictions data
	To be changed later

	* ali.ads, checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb,
	exp_ch3.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_util.adb,
	freeze.adb, gnat1drv.adb, sem_attr.adb, sem_ch10.adb, sem_ch11.adb,
	sem_ch12.adb, targparm.adb, targparm.ads, tbuild.adb, sem_ch2.adb,
	sem_elab.adb, sem_res.adb: Minor changes for new restrictions handling.

	* exp_ch9.adb (Build_Master_Entity): Cleanup the code (also suppresses
	the warning message on access to possibly uninitialized variable S)
	Minor changes for new restrictions handling.

	* gnatbind.adb: Minor reformatting
	Minor changes for new restrictions handling
	Move circuit for -r processing here from bcheck (cleaner)

	* gnatcmd.adb, gnatlink.adb: Minor reformatting

	* lib-writ.adb: Output new format restrictions lines

	* lib-writ.ads: Document new R format lines for new restrictions
	handling.

	* s-restri.ads/adb: New files

	* Makefile.rtl: Add entry for s-restri.ads/adb

	* par-ch3.adb: Fix bad error messages starting with upper case letter
	Minor reformatting

	* restrict.adb: Major rewrite throughout for new restrictions handling
	Major point is to handle restrictions with parameters

	* restrict.ads: Major changes in interface to handle restrictions with
	parameters. Also generally simplifies setting of restrictions.

	* snames.ads/adb: New entry for proper handling of No_Requeue

	* sem_ch3.adb (Count_Tasks): New circuitry for implementing Max_Tasks
	restriction counting.
	Other minor changes for new restrictions handling

	* sem_prag.adb: No_Requeue is a synonym for No_Requeue_Statements.
	Restriction_Warnings now allows full parameter notation
	Major rewrite of Restrictions for new restrictions handling

2004-02-02  Javier Miranda  <miranda@gnat.com>

	* par-ch3.adb (P_Identifier_Declarations): Give support to the Ada 0Y
	syntax rule for object renaming declarations.
	(P_Array_Type_Definition): Give support for the Ada 0Y syntax rule for
	component definitions.

	* sem_ch3.adb (Analyze_Component_Declaration): Give support to access
	components.
	(Array_Type_Declaration): Give support to access components. In addition
	it was also modified to reflect the name of the object in anonymous
	array types. The old code did not take into account that it is possible
	to have an unconstrained anonymous array with an initial value.
	(Check_Or_Process_Discriminants): Allow access discriminant in
	non-limited types.
	(Process_Discriminants): Allow access discriminant in non-limited types
	Initialize the new Access_Definition field in N_Object_Renaming_Decl
	node.  Change Ada0Y to Ada 0Y in comments

	* sem_ch4.adb (Find_Equality_Types): Allow anonymous access types in
	equality operators.
	Change Ada0Y to Ada 0Y in comments

	* sem_ch8.adb (Analyze_Object_Renaming): Give support to access
	renamings Change Ada0Y to Ada 0Y in comments

	* sem_type.adb (Find_Unique_Type): Give support to the equality
	operators for universal access types
	Change Ada0Y to Ada 0Y in comments

	* sinfo.adb (Access_Definition, Set_Access_Definition): New subprograms

	* sinfo.ads (N_Component_Definition): Addition of Access_Definition
	field.
	(N_Object_Renaming_Declaration): Addition of Access_Definition field
	Change Ada0Y to Ada 0Y in comments

	* sprint.adb (Sprint_Node_Actual): Give support to the new syntax for
	component definition and object renaming nodes
	Change Ada0Y to Ada 0Y in comments

2004-02-02  Jose Ruiz  <ruiz@act-europe.fr>

	* restrict.adb: Use the new restriction identifier
	No_Requeue_Statements instead of the old No_Requeue for defining the
	restricted profile.

	* sem_ch9.adb (Analyze_Requeue): Check the new restriction
	No_Requeue_Statements.

	* s-rident.ads: Adding restriction No_Requeue_Statements (AI-00249)
	that supersedes the GNAT specific restriction No_Requeue. The later is
	kept for backward compatibility.

2004-02-02  Ed Schonberg  <schonberg@gnat.com>

	* lib.ads, i-cobol.ads, * s-stoele.ads, s-thread.ads, style.ads,
	5staprop.adb, atree.adb, atree.ads, g-crc32.ads: Remove redundant
	pragma and fix incorrect ones.

	* sem_prag.adb For pragma Inline and pragma Pure_Function, emit a
	warning if the pragma is redundant.

2004-02-02  Thomas Quinot  <quinot@act-europe.fr>

	* 5staprop.adb: Add missing 'constant' keywords.

	* Makefile.in: use consistent value for SYMLIB on
	platforms where libaddr2line is supported.

2004-02-02  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* utils.c (end_subprog_body): Do not call rest_of_compilation if just
	annotating types.

2004-02-02  Olivier Hainque  <hainque@act-europe.fr>

	* init.c (__gnat_install_handler): Setup an alternate stack for signal
	handlers in the environment thread. This allows proper propagation of
	an exception on stack overflows in this thread even when the builtin
	ABI stack-checking scheme is used without support for a stack reserve
	region.

	* utils.c (create_field_decl): Augment the head comment about bitfield
	creation, and don't account for DECL_BIT_FIELD in DECL_NONADDRESSABLE_P
	here, because the former is not accurate enough at this point.
	Let finish_record_type decide instead.
	Don't make a bitfield if the field is to be addressable.
	Always set a size for the field if the record is packed, to ensure the
	checks for bitfield creation are triggered.
	(finish_record_type): During last pass over the fields, clear
	DECL_BIT_FIELD when possible in the !STRICT_ALIGNMENT case, as this is
	not covered by the calls to layout_decl.  Adjust DECL_NONADDRESSABLE_P
	from DECL_BIT_FIELD.

From-SVN: r77110
2004-02-02 13:32:01 +01:00

1958 lines
66 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 1 1 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 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 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;
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 Restriction_Active (No_Exception_Handlers) then
return;
end if;
if Present (Block) then
New_Scope (Block);
end if;
Ohandle :=
Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
Stmnts := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Clean, Loc)),
Make_Raise_Statement (Loc));
Set_Exception_Handlers (HSS, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => Stmnts)));
Analyze_List (Stmnts, Suppress => All_Checks);
Expand_Exception_Handlers (HSS);
if Present (Block) then
Pop_Scope;
end if;
end Expand_At_End_Handler;
-------------------------------------
-- Expand_Exception_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 Restriction_Active (No_Exception_Handlers)
and then not Restriction_Active (No_Exception_Registration)
then
L := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
Set_Register_Exception_Call (Id, First (L));
if not Is_Library_Level_Entity (Id) then
Flag_Id := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Id), 'F'));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)));
Set_Is_Statically_Allocated (Flag_Id);
Append_To (L,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Flag_Id, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)));
Insert_After_And_Analyze (N,
Make_Implicit_If_Statement (N,
Condition => New_Occurrence_Of (Flag_Id, Loc),
Then_Statements => L));
else
Insert_List_After_And_Analyze (N, L);
end if;
end if;
end Expand_N_Exception_Declaration;
---------------------------------------------
-- Expand_N_Handled_Sequence_Of_Statements --
---------------------------------------------
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
begin
if Present (Exception_Handlers (N))
and then not Restriction_Active (No_Exception_Handlers)
then
Expand_Exception_Handlers (N);
end if;
-- The following code needs comments ???
if Nkind (Parent (N)) /= N_Package_Body
and then Nkind (Parent (N)) /= N_Accept_Statement
and then not Delay_Cleanups (Current_Scope)
then
Expand_Cleanup_Actions (Parent (N));
else
Set_First_Real_Statement (N, First (Statements (N)));
end if;
end Expand_N_Handled_Sequence_Of_Statements;
-------------------------------------
-- Expand_N_Raise_Constraint_Error --
-------------------------------------
-- The only processing required is to adjust the condition to deal
-- with the C/Fortran boolean case. This may well not be necessary,
-- as all such conditions are generated by the expander and probably
-- are all standard boolean, but who knows what strange optimization
-- in future may require this adjustment!
procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Constraint_Error;
----------------------------------
-- Expand_N_Raise_Program_Error --
----------------------------------
-- The only processing required is to adjust the condition to deal
-- with the C/Fortran boolean case. This may well not be necessary,
-- as all such conditions are generated by the expander and probably
-- are all standard boolean, but who knows what strange optimization
-- in future may require this adjustment!
procedure Expand_N_Raise_Program_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Program_Error;
------------------------------
-- Expand_N_Raise_Statement --
------------------------------
procedure Expand_N_Raise_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ehand : Node_Id;
E : Entity_Id;
Str : String_Id;
begin
-- There is no expansion needed for statement "raise <exception>;" when
-- compiling for the JVM since the JVM has a built-in exception
-- mechanism. However we need the keep the expansion for "raise;"
-- statements. See 4jexcept.ads for details.
if Present (Name (N)) and then Hostparm.Java_VM then
return;
end if;
-- Don't expand a raise statement that does not come from source
-- if we have already had configurable run-time violations, since
-- most likely it will be junk cascaded nonsense.
if Configurable_Run_Time_Violations > 0
and then not Comes_From_Source (N)
then
return;
end if;
-- Convert explicit raise of Program_Error, Constraint_Error, and
-- Storage_Error into the corresponding raise (in High_Integrity_Mode
-- all other raises will get normal expansion and be disallowed,
-- but this is also faster in all modes).
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
if Entity (Name (N)) = Standard_Constraint_Error then
Rewrite (N,
Make_Raise_Constraint_Error (Loc,
Reason => CE_Explicit_Raise));
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Program_Error then
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Explicit_Raise));
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Storage_Error then
Rewrite (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Explicit_Raise));
Analyze (N);
return;
end if;
end if;
-- Case of name present, in this case we expand raise name to
-- Raise_Exception (name'Identity, location_string);
-- where location_string identifies the file/line of the raise
if Present (Name (N)) then
declare
Id : Entity_Id := Entity (Name (N));
begin
Build_Location_String (Loc);
-- If the exception is a renaming, use the exception that it
-- renames (which might be a predefined exception, e.g.).
if Present (Renamed_Object (Id)) then
Id := Renamed_Object (Id);
end if;
-- Build a C-compatible string in case of no exception handlers,
-- since this is what the last chance handler is expecting.
if Restriction_Active (No_Exception_Handlers) then
-- Generate an empty message if configuration pragma
-- Suppress_Exception_Locations is set for this unit.
if Opt.Exception_Locations_Suppressed then
Name_Len := 1;
else
Name_Len := Name_Len + 1;
end if;
Name_Buffer (Name_Len) := ASCII.NUL;
end if;
if Opt.Exception_Locations_Suppressed then
Name_Len := 0;
end if;
Str := String_From_Name_Buffer;
-- For VMS exceptions, convert the raise into a call to
-- lib$stop so it will be handled by __gnat_error_handler.
if Is_VMS_Exception (Id) then
declare
Excep_Image : String_Id;
Cond : Node_Id;
begin
if Present (Interface_Name (Id)) then
Excep_Image := Strval (Interface_Name (Id));
else
Get_Name_String (Chars (Id));
Set_All_Upper_Case;
Excep_Image := String_From_Name_Buffer;
end if;
if Exception_Code (Id) /= No_Uint then
Cond :=
Make_Integer_Literal (Loc, Exception_Code (Id));
else
Cond :=
Unchecked_Convert_To (Standard_Integer,
Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Import_Value), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image))));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
Parameter_Associations => New_List (Cond)));
Analyze_And_Resolve (Cond, Standard_Integer);
end;
-- Not VMS exception case, convert raise to call to the
-- Raise_Exception routine.
else
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Identity),
Make_String_Literal (Loc,
Strval => Str))));
end if;
end;
-- Case of no name present (reraise). We rewrite the raise to:
-- Reraise_Occurrence_Always (EO);
-- where EO is the current exception occurrence. If the current handler
-- does not have a choice parameter specification, then we provide one.
else
-- Find innermost enclosing exception handler (there must be one,
-- since the semantics has already verified that this raise statement
-- is valid, and a raise with no arguments is only permitted in the
-- context of an exception handler.
Ehand := Parent (N);
while Nkind (Ehand) /= N_Exception_Handler loop
Ehand := Parent (Ehand);
end loop;
-- Make exception choice parameter if none present. Note that we do
-- not need to put the entity on the entity chain, since no one will
-- be referencing this entity by normal visibility methods.
if No (Choice_Parameter (Ehand)) then
E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Set_Choice_Parameter (Ehand, E);
Set_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
Set_Scope (E, Current_Scope);
end if;
-- Now rewrite the raise as a call to Reraise. A special case arises
-- if this raise statement occurs in the context of a handler for
-- all others (i.e. an at end handler). in this case we avoid
-- the call to defer abort, cleanup routines are expected to be
-- called in this case with aborts deferred.
declare
Ech : constant Node_Id := First (Exception_Choices (Ehand));
Ent : Entity_Id;
begin
if Nkind (Ech) = N_Others_Choice
and then All_Others (Ech)
then
Ent := RTE (RE_Reraise_Occurrence_No_Defer);
else
Ent := RTE (RE_Reraise_Occurrence_Always);
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
end;
end if;
Analyze (N);
end Expand_N_Raise_Statement;
----------------------------------
-- Expand_N_Raise_Storage_Error --
----------------------------------
-- The only processing required is to adjust the condition to deal
-- with the C/Fortran boolean case. This may well not be necessary,
-- as all such conditions are generated by the expander and probably
-- are all standard boolean, but who knows what strange optimization
-- in future may require this adjustment!
procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
begin
Adjust_Condition (Condition (N));
end Expand_N_Raise_Storage_Error;
------------------------------
-- Expand_N_Subprogram_Info --
------------------------------
procedure Expand_N_Subprogram_Info (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
-- For now, we replace an Expand_N_Subprogram_Info node with an
-- attribute reference that gives the address of the procedure.
-- This is because gigi does not yet recognize this node, and
-- for the initial targets, this is the right value anyway.
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Identifier (N),
Attribute_Name => Name_Code_Address));
Analyze_And_Resolve (N, RTE (RE_Code_Loc));
end Expand_N_Subprogram_Info;
------------------------------------
-- 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 --
----------------------
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;
Reference in New Issue View Git Blame Copy Permalink