mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 11:30:33 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR ada/23646 (Ada testsuite hangs -- many new failures)

Browse Source 
PR ada/23646

	* s-mastop-tru64.adb, s-mastop-irix.adb, s-mastop-vms.adb
	(Enter_Handler, Set_Signal_Machine_State): Removed, no longer used.
	Remove reference to System.Exceptions.

	* s-mastop-x86.adb: Removed, no longer used.

	* s-traceb-mastop.adb: Adjust calls to Pop_Frame.

	* a-excach.adb: Minor reformatting.

	* a-except.ads, a-except.adb: Remove global Warnings (Off) pragma, and
	instead fix new warnings that were hidden by this change.
	(AAA, ZZZ): Removed, replaced by...
	(Code_Address_For_AAA, Code_Address_For_ZZZ): ... these functions, who
	are used instead of constants, to help make Ada.Exception truly
	preelaborate.
	(Rcheck_*, Raise_Constraint_Error, Raise_Program_Error,
	Raise_Storage_Error): File is now a System.Address, to simplify code.
	(Elab code): Removed, no longer used.
	(Null_Occurrence): Remove Warnings Off and make this construct
	preelaborate.
	Remove code related to front-end zero cost exception handling, since
	it is no longer used.
	Remove -gnatL/-gnatZ switches.

	* a-exexda.adb (Append_Info_Exception_Name, Set_Exception_C_Msg):
	Update use of Except.Msg.

	* gnat1drv.adb, inline.adb, bindgen.adb, debug.adb, exp_ch11.ads,
	freeze.adb, frontend.adb, lib.adb, exp_ch11.adb: Remove code related
	to front-end zero cost exception handling, since it is no longer used.
	Remove -gnatL/-gnatZ switches.

	* lib-writ.ads: Minor reformatting
	Remove doc of UX

	* Makefile.rtl: Remove references to s-except*, s-mastop-x86*

	* Make-lang.in: Remove references to s-except.ads

	* s-except.ads: Removed, no longer used.

	* s-mastop.ads, s-mastop.adb:
	(Enter_Handler, Set_Signal_Machine_State): Removed, no longer used.
	Remove reference to System.Exceptions.

	* raise.h, usage.adb, targparm.adb, targparm.ads, switch-m.adb,
	switch-b.adb: Remove code related to front-end zero cost exception
	handling, since it is no longer used.
	Remove -gnatL/-gnatZ switches.

From-SVN: r103848
This commit is contained in:
Arnaud Charlet 2005-09-05 09:46:59 +02:00
parent 3b91d88ea1
commit 1a2c495da9
30 changed files with 255 additions and 3050 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/Make-lang.in
View File

@ -113,7 +113,7 @@ GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \
GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \
ada/a-elchha.o ada/a-ioexce.o \
ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \
ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/s-except.o ada/ali.o \
ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/ali.o \
ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \
ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \
ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \
@ -215,7 +215,6 @@ GNATBIND_OBJS = \
ada/s-casuti.o \
ada/s-crc32.o \
ada/s-crtl.o \
ada/s-except.o \
ada/s-exctab.o \
ada/s-htable.o \
ada/s-imgenu.o \
@ -1101,7 +1100,7 @@ ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \
ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \
ada/a-elchha.ads ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads \
ada/a-uncdea.ads ada/interfac.ads ada/system.ads ada/s-exctab.ads \
ada/s-except.ads ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \
ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \
ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/s-traceb.ads ada/s-traent.ads ada/s-traent.adb ada/s-unstyp.ads \
ada/unchconv.ads
@ -2606,9 +2605,6 @@ ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \
ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads
ada/s-except.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-stalib.ads ada/s-traent.ads ada/unchconv.ads
ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
ada/s-htable.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
@ -2621,7 +2617,7 @@ ada/s-imgenu.o : ada/system.ads ada/s-imgenu.ads ada/s-imgenu.adb \
ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/s-mastop.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-mastop.ads ada/s-mastop.adb ada/s-stalib.ads \
ada/s-mastop.ads ada/s-mastop.adb ada/s-stalib.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads
ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/system.ads \
@ -2639,7 +2635,7 @@ ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-traent.ads ada/unchconv.ads ada/unchdeal.ads
ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-mastop.ads ada/s-parame.ads ada/s-secsta.ads \
ada/s-mastop.ads ada/s-parame.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads

1
gcc/ada/Makefile.rtl
View File

@ -375,7 +375,6 @@ GNATRTL_NONTASKING_OBJS= \
s-crc32$(objext) \
s-direio$(objext) \
s-errrep$(objext) \
s-except$(objext) \
s-exctab$(objext) \
s-exnint$(objext) \
s-exnllf$(objext) \

1
gcc/ada/a-excach.adb
View File

@ -71,7 +71,6 @@ begin
Exclude_Min => Code_Address_For_AAA,
Exclude_Max => Code_Address_For_ZZZ,
Skip_Frames => 3);
end if;
end Call_Chain;

363
gcc/ada/a-except.adb
View File

@ -35,14 +35,9 @@ pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with System.Exception_Tables.
pragma Warnings (Off);
-- Since several constructs give warnings in 3.14a1, including unreferenced
-- variables and pragma Unreferenced itself.
with System; use System;
with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links;
with System.Machine_State_Operations; use System.Machine_State_Operations;
package body Ada.Exceptions is
@ -71,11 +66,11 @@ package body Ada.Exceptions is
-- from C clients using the given external name, even though they are not
-- technically visible in the Ada sense.
procedure AAA;
procedure ZZZ;
-- Mark start and end of procedures in this package
function Code_Address_For_AAA return System.Address;
function Code_Address_For_ZZZ return System.Address;
-- Return start and end of procedures in this package
--
-- The AAA and ZZZ procedures are used to provide exclusion bounds in
-- These procedures are used to provide exclusion bounds in
-- calls to Call_Chain at exception raise points from this unit. The
-- purpose is to arrange for the exception tracebacks not to include
-- frames from routines involved in the raise process, as these are
@ -83,27 +78,18 @@ package body Ada.Exceptions is
--
-- For these bounds to be meaningful, we need to ensure that the object
-- code for the routines involved in processing a raise is located after
-- the object code for AAA and before the object code for ZZZ. This will
-- indeed be the case as long as the following rules are respected:
-- the object code Code_Address_For_AAA and before the object code
-- Code_Address_For_ZZZ. This will indeed be the case as long as the
-- following rules are respected:
--
-- 1) The bodies of the subprograms involved in processing a raise
-- are located after the body of AAA and before the body of ZZZ.
-- are located after the body of Code_Address_For_AAA and before the
-- body of Code_Address_For_ZZZ.
--
-- 2) No pragma Inline applies to any of these subprograms, as this
-- could delay the corresponding assembly output until the end of
-- the unit.
Code_Address_For_AAA, Code_Address_For_ZZZ : System.Address;
-- Used to represent addresses really inside the code range for AAA and
-- ZZZ, initialized to the address of a label inside the corresponding
-- procedure. This is initialization takes place inside the procedures
-- themselves, which are called as part of the elaboration code.
--
-- We are doing this instead of merely using Proc'Address because on some
-- platforms the latter does not yield the address we want, but the
-- address of a stub or of a descriptor instead. This is the case at least
-- on Alpha-VMS and PA-HPUX.
procedure Call_Chain (Excep : EOA);
-- Store up to Max_Tracebacks in Excep, corresponding to the current
-- call chain.
@ -139,9 +125,9 @@ package body Ada.Exceptions is
procedure Set_Exception_C_Msg
(Id : Exception_Id;
Msg1 : Big_String_Ptr;
Msg1 : System.Address;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null);
Msg2 : System.Address := System.Null_Address);
-- This routine is called to setup the exception referenced by the
-- Current_Excep field in the TSD to contain the indicated Id value
-- and message. Msg1 is a null terminated string which is generated
@ -210,7 +196,7 @@ package body Ada.Exceptions is
pragma Export
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
-- This is currently used by System.Tasking.Stages.
-- This is currently used by System.Tasking.Stages
end Exception_Data;
@ -329,9 +315,9 @@ package body Ada.Exceptions is
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
F : System.Address;
L : Integer;
M : Big_String_Ptr := null);
M : System.Address := System.Null_Address);
pragma No_Return (Raise_With_Location_And_Msg);
-- Raise an exception with given exception id value. A filename and line
-- number is associated with the raise and is stored in the exception
@ -339,7 +325,7 @@ package body Ada.Exceptions is
-- this (if M is not null).
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer);
pragma No_Return (Raise_Constraint_Error);
pragma Export
@ -347,16 +333,16 @@ package body Ada.Exceptions is
-- Raise constraint error with file:line information
procedure Raise_Constraint_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr);
Msg : System.Address);
pragma No_Return (Raise_Constraint_Error_Msg);
pragma Export
(C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
-- Raise constraint error with file:line + msg information
procedure Raise_Program_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer);
pragma No_Return (Raise_Program_Error);
pragma Export
@ -364,16 +350,16 @@ package body Ada.Exceptions is
-- Raise program error with file:line information
procedure Raise_Program_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr);
Msg : System.Address);
pragma No_Return (Raise_Program_Error_Msg);
pragma Export
(C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
-- Raise program error with file:line + msg information
procedure Raise_Storage_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer);
pragma No_Return (Raise_Storage_Error);
pragma Export
@ -381,9 +367,9 @@ package body Ada.Exceptions is
-- Raise storage error with file:line information
procedure Raise_Storage_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr);
Msg : System.Address);
pragma No_Return (Raise_Storage_Error_Msg);
pragma Export
(C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
@ -454,37 +440,37 @@ package body Ada.Exceptions is
-- to the codes defined in Types.ads and a-types.h (for example,
-- the name Rcheck_05 refers to the Reason whose Pos code is 5).
procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_30 (File : Big_String_Ptr; Line : Integer);
procedure Rcheck_00 (File : System.Address; Line : Integer);
procedure Rcheck_01 (File : System.Address; Line : Integer);
procedure Rcheck_02 (File : System.Address; Line : Integer);
procedure Rcheck_03 (File : System.Address; Line : Integer);
procedure Rcheck_04 (File : System.Address; Line : Integer);
procedure Rcheck_05 (File : System.Address; Line : Integer);
procedure Rcheck_06 (File : System.Address; Line : Integer);
procedure Rcheck_07 (File : System.Address; Line : Integer);
procedure Rcheck_08 (File : System.Address; Line : Integer);
procedure Rcheck_09 (File : System.Address; Line : Integer);
procedure Rcheck_10 (File : System.Address; Line : Integer);
procedure Rcheck_11 (File : System.Address; Line : Integer);
procedure Rcheck_12 (File : System.Address; Line : Integer);
procedure Rcheck_13 (File : System.Address; Line : Integer);
procedure Rcheck_14 (File : System.Address; Line : Integer);
procedure Rcheck_15 (File : System.Address; Line : Integer);
procedure Rcheck_16 (File : System.Address; Line : Integer);
procedure Rcheck_17 (File : System.Address; Line : Integer);
procedure Rcheck_18 (File : System.Address; Line : Integer);
procedure Rcheck_19 (File : System.Address; Line : Integer);
procedure Rcheck_20 (File : System.Address; Line : Integer);
procedure Rcheck_21 (File : System.Address; Line : Integer);
procedure Rcheck_22 (File : System.Address; Line : Integer);
procedure Rcheck_23 (File : System.Address; Line : Integer);
procedure Rcheck_24 (File : System.Address; Line : Integer);
procedure Rcheck_25 (File : System.Address; Line : Integer);
procedure Rcheck_26 (File : System.Address; Line : Integer);
procedure Rcheck_27 (File : System.Address; Line : Integer);
procedure Rcheck_28 (File : System.Address; Line : Integer);
procedure Rcheck_29 (File : System.Address; Line : Integer);
procedure Rcheck_30 (File : System.Address; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
@ -611,19 +597,25 @@ package body Ada.Exceptions is
-- The actual polling routine is separate, so that it can easily
-- be replaced with a target dependent version.
---------
-- AAA --
---------
--------------------------
-- Code_Address_For_AAA --
--------------------------
-- This dummy procedure gives us the start of the PC range for addresses
-- This function gives us the start of the PC range for addresses
-- within the exception unit itself. We hope that gigi/gcc keep all the
-- procedures in their original order!
procedure AAA is
function Code_Address_For_AAA return System.Address is
begin
-- We are using a label instead of merely using
-- Code_Address_For_AAA'Address because on some platforms the latter
-- does not yield the address we want, but the address of a stub or of
-- a descriptor instead. This is the case at least on Alpha-VMS and
-- PA-HPUX.
<<Start_Of_AAA>>
Code_Address_For_AAA := Start_Of_AAA'Address;
end AAA;
return Start_Of_AAA'Address;
end Code_Address_For_AAA;
----------------
-- Call_Chain --
@ -714,7 +706,7 @@ package body Ada.Exceptions is
raise Constraint_Error;
end if;
return Id.Full_Name.all (1 .. Id.Name_Length - 1);
return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
end Exception_Name;
function Exception_Name (X : Exception_Occurrence) return String is
@ -793,7 +785,7 @@ package body Ada.Exceptions is
-- This is so the debugger can reliably inspect the parameter
Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
Excep : EOA := Get_Current_Excep.all;
Excep : constant EOA := Get_Current_Excep.all;
begin
-- WARNING : There should be no exception handler for this body
@ -803,43 +795,44 @@ package body Ada.Exceptions is
-- we are handling, which would completely break the whole design
-- of this procedure.
-- Processing varies between zero cost and setjmp/lonjmp processing.
-- Processing varies between zero cost and setjmp/lonjmp processing
if Zero_Cost_Exceptions /= 0 then
-- Use the front-end tables to propagate if we have them, otherwise
-- resort to the GCC back-end alternative. Backtrace computation is
-- performed, if required, by the underlying routine. Notifications
-- for the debugger are also not performed here, because we do not
-- yet know if the exception is handled.
-- Use the GCC back-end to propagate the exception. Backtrace
-- computation is performed, if required, by the underlying routine.
-- Notifications for the debugger are also not performed here,
-- because we do not yet know if the exception is handled.
Exception_Propagation.Propagate_Exception (From_Signal_Handler);
else
-- Compute the backtrace for this occurrence if the corresponding
-- binder option has been set. Call_Chain takes care of the reraise
-- case.
-- Compute the backtrace for this occurrence if corresponding binder
-- option has been set. Call_Chain takes care of the reraise case.
Call_Chain (Excep);
-- Note on above call to Call_Chain:
-- We used to only do this if From_Signal_Handler was not set,
-- based on the assumption that backtracing from a signal handler
-- would not work due to stack layout oddities. However, since
--
-- 1. The flag is never set in tasking programs (Notify_Exception
-- performs regular raise statements), and
--
-- 2. No problem has shown up in tasking programs around here so
-- far, this turned out to be too strong an assumption.
--
-- As, in addition, the test was
--
-- 1. preventing the production of backtraces in non-tasking
-- programs, and
--
-- 2. introducing a behavior inconsistency between
-- the tasking and non-tasking cases,
--
-- we have simply removed it.
-- we have simply removed it
-- If the jump buffer pointer is non-null, transfer control using
-- it. Otherwise announce an unhandled exception (note that this
@ -872,7 +865,7 @@ package body Ada.Exceptions is
----------------------------
procedure Raise_Constraint_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer)
is
begin
@ -885,9 +878,9 @@ package body Ada.Exceptions is
--------------------------------
procedure Raise_Constraint_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr)
Msg : System.Address)
is
begin
Raise_With_Location_And_Msg
@ -941,7 +934,7 @@ package body Ada.Exceptions is
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : Big_String_Ptr)
M : System.Address)
is
begin
Exception_Data.Set_Exception_C_Msg (E, M);
@ -954,7 +947,7 @@ package body Ada.Exceptions is
-------------------------
procedure Raise_Program_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer)
is
begin
@ -967,9 +960,9 @@ package body Ada.Exceptions is
-----------------------------
procedure Raise_Program_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr)
Msg : System.Address)
is
begin
Raise_With_Location_And_Msg
@ -981,7 +974,7 @@ package body Ada.Exceptions is
-------------------------
procedure Raise_Storage_Error
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer)
is
begin
@ -994,9 +987,9 @@ package body Ada.Exceptions is
-----------------------------
procedure Raise_Storage_Error_Msg
(File : Big_String_Ptr;
(File : System.Address;
Line : Integer;
Msg : Big_String_Ptr)
Msg : System.Address)
is
begin
Raise_With_Location_And_Msg
@ -1009,9 +1002,9 @@ package body Ada.Exceptions is
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
F : System.Address;
L : Integer;
M : Big_String_Ptr := null)
M : System.Address := System.Null_Address)
is
begin
Exception_Data.Set_Exception_C_Msg (E, F, L, M);
@ -1042,159 +1035,159 @@ package body Ada.Exceptions is
-- Calls to Run-Time Check Routines --
--------------------------------------
procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_00 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
end Rcheck_00;
procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_01 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
end Rcheck_01;
procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_02 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
end Rcheck_02;
procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_03 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
end Rcheck_03;
procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_04 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
end Rcheck_04;
procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_05 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
end Rcheck_05;
procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_06 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
end Rcheck_06;
procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_07 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
end Rcheck_07;
procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_08 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
end Rcheck_08;
procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_09 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
end Rcheck_09;
procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_10 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
end Rcheck_10;
procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_11 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
end Rcheck_11;
procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_12 (File : System.Address; Line : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address));
Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
end Rcheck_12;
procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_13 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_13'Address);
end Rcheck_13;
procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_14 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
end Rcheck_14;
procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_15 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
end Rcheck_15;
procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_16 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
end Rcheck_16;
procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_17 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
end Rcheck_17;
procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_18 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
end Rcheck_18;
procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_19 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
end Rcheck_19;
procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_20 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
end Rcheck_20;
procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_21 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
end Rcheck_21;
procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_22 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
end Rcheck_22;
procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_23 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
end Rcheck_23;
procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_24 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
end Rcheck_24;
procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_25 (File : System.Address; Line : Integer) is
begin
Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address));
Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
end Rcheck_25;
procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_26 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address));
Raise_Storage_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_26;
procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_27 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address));
Raise_Storage_Error_Msg (File, Line, Rmsg_27'Address);
end Rcheck_27;
procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_28 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address));
Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_28;
procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_29 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_29'Address));
Raise_Storage_Error_Msg (File, Line, Rmsg_29'Address);
end Rcheck_29;
procedure Rcheck_30 (File : Big_String_Ptr; Line : Integer) is
procedure Rcheck_30 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_30'Address));
Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_30;
-------------
@ -1263,7 +1256,7 @@ package body Ada.Exceptions is
end Save_Occurrence;
function Save_Occurrence (Source : Exception_Occurrence) return EOA is
Target : EOA := new Exception_Occurrence;
Target : constant EOA := new Exception_Occurrence;
begin
Save_Occurrence (Target.all, Source);
return Target;
@ -1348,8 +1341,7 @@ package body Ada.Exceptions is
begin
Exception_Data.Set_Exception_Msg (E, Message);
-- DO NOT CALL Abort_Defer.all; !!!!
-- why not??? would be nice to have more comments here
-- Do not call Abort_Defer.all, as specified by the spec
Raise_Current_Excep (E);
end Raise_Exception_No_Defer;
@ -1378,35 +1370,18 @@ package body Ada.Exceptions is
end loop;
end To_Stderr;
---------
-- ZZZ --
---------
--------------------------
-- Code_Address_For_ZZZ --
--------------------------
-- This dummy procedure gives us the end of the PC range for addresses
-- This function gives us the end of the PC range for addresses
-- within the exception unit itself. We hope that gigi/gcc keeps all the
-- procedures in their original order!
procedure ZZZ is
function Code_Address_For_ZZZ return System.Address is
begin
<<Start_Of_ZZZ>>
Code_Address_For_ZZZ := Start_Of_ZZZ'Address;
end ZZZ;
return Start_Of_ZZZ'Address;
end Code_Address_For_ZZZ;
begin
pragma Warnings (Off);
-- Allow calls to non-static subprograms in Ada 2005 mode where this
-- package will be implicitly categorized as Preelaborate. See AI-362 for
-- details. It is safe in the context of the run-time to violate the rules!
-- Allocate the Non-Tasking Machine_State
Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
-- Call the AAA/ZZZ routines to setup the code addresses for the
-- bounds of this unit.
AAA;
ZZZ;
pragma Warnings (On);
end Ada.Exceptions;

77
gcc/ada/a-except.ads
View File

@ -39,24 +39,18 @@ pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with ourself.
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
-- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules!
with System;
with System.Parameters;
with System.Standard_Library;
with System.Traceback_Entries;
pragma Warnings (On);
package Ada.Exceptions is
pragma Warnings (Off);
pragma Preelaborate_05 (Exceptions);
pragma Warnings (On);
-- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we can
-- compile this using older compiler versions, which will ignore the pragma,
-- which is fine for the bootstrap.
pragma Warnings (Off);
pragma Preelaborate_05;
pragma Warnings (On);
-- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we
-- can compile this using older compiler versions, which will ignore the
-- pragma, which is fine for the bootstrap.
type Exception_Id is private;
Null_Id : constant Exception_Id;
@ -127,10 +121,9 @@ private
------------------
subtype Code_Loc is System.Address;
-- Code location used in building exception tables and for call
-- addresses when propagating an exception.
-- Values of this type are created by using Label'Address or
-- extracted from machine states using Get_Code_Loc.
-- Code location used in building exception tables and for call addresses
-- when propagating an exception. Values of this type are created by using
-- Label'Address or extracted from machine states using Get_Code_Loc.
Null_Loc : constant Code_Loc := System.Null_Address;
-- Null code location, used to flag outer level frame
@ -161,12 +154,12 @@ private
-- to be in the visible part, since this is set by the reference manual).
function Exception_Name_Simple (X : Exception_Occurrence) return String;
-- Like Exception_Name, but returns the simple non-qualified name of
-- the exception. This is used to implement the Exception_Name function
-- in Current_Exceptions (the DEC compatible unit). It is called from
-- the compiler generated code (using Rtsfind, which does not respect
-- the private barrier, so we can place this function in the private
-- part where the compiler can find it, but the spec is unchanged.)
-- Like Exception_Name, but returns the simple non-qualified name of the
-- exception. This is used to implement the Exception_Name function in
-- Current_Exceptions (the DEC compatible unit). It is called from the
-- compiler generated code (using Rtsfind, which does not respect the
-- private barrier, so we can place this function in the private part
-- where the compiler can find it, but the spec is unchanged.)
procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
pragma No_Return (Raise_Exception_Always);
@ -179,22 +172,21 @@ private
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : SSL.Big_String_Ptr);
M : System.Address);
pragma Export
(Ada, Raise_From_Signal_Handler,
"ada__exceptions__raise_from_signal_handler");
pragma No_Return (Raise_From_Signal_Handler);
-- This routine is used to raise an exception from a signal handler.
-- The signal handler has already stored the machine state (i.e. the
-- state that corresponds to the location at which the signal was
-- raised). E is the Exception_Id specifying what exception is being
-- raised, and M is a pointer to a null-terminated string which is the
-- message to be raised. Note that this routine never returns, so it is
-- permissible to simply jump to this routine, rather than call it. This
-- may be appropriate for systems where the right way to get out of a
-- signal handler is to alter the PC value in the machine state or in
-- some other way ask the operating system to return here rather than
-- to the original location.
-- This routine is used to raise an exception from a signal handler. The
-- signal handler has already stored the machine state (i.e. the state that
-- corresponds to the location at which the signal was raised). E is the
-- Exception_Id specifying what exception is being raised, and M is a
-- pointer to a null-terminated string which is the message to be raised.
-- Note that this routine never returns, so it is permissible to simply
-- jump to this routine, rather than call it. This may be appropriate for
-- systems where the right way to get out of signal handler is to alter the
-- PC value in the machine state or in some other way ask the operating
-- system to return here rather than to the original location.
procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_Always);
@ -207,8 +199,8 @@ private
pragma No_Return (Reraise_Occurrence_No_Defer);
-- Exactly like Reraise_Occurrence, except that abort is not deferred
-- before the call and the parameter X is known not to be the null
-- occurrence. This is used in generated code when it is known
-- that abort is already deferred.
-- occurrence. This is used in generated code when it is known that
-- abort is already deferred.
-----------------------
-- Polling Interface --
@ -260,7 +252,7 @@ private
Msg : String (1 .. Exception_Msg_Max_Length);
-- Characters of message
Cleanup_Flag : Boolean;
Cleanup_Flag : Boolean := False;
-- The cleanup flag is normally False, it is set True for an exception
-- occurrence passed to a cleanup routine, and will still be set True
-- when the cleanup routine does a Reraise_Occurrence call using this
@ -276,7 +268,7 @@ private
-- it is dealing with the reraise case (which is useful to distinguish
-- for exception tracing purposes).
Pid : Natural;
Pid : Natural := 0;
-- Partition_Id for partition raising exception
Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0;
@ -302,13 +294,8 @@ private
pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String);
-- Functions for implementing Exception_Occurrence stream attributes
pragma Warnings (Off);
-- Allow non-static constants in Ada 2005 mode where this package will be
-- implicitly categorized as Preelaborate. See AI-362 for details. It is
-- safe in the context of the run-time to violate the rules!
Null_Occurrence : constant Exception_Occurrence := (
Id => Null_Id,
Id => null,
Msg_Length => 0,
Msg => (others => ' '),
Cleanup_Flag => False,
@ -318,6 +305,4 @@ private
Tracebacks => (others => TBE.Null_TB_Entry),
Private_Data => System.Null_Address);
pragma Warnings (On);
end Ada.Exceptions;

16
gcc/ada/a-exexda.adb
View File

@ -476,7 +476,7 @@ package body Exception_Data is
declare
Len : constant Natural := Exception_Name_Length (Id);
Name : constant String (1 .. Len) := Id.Full_Name (1 .. Len);
Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
begin
Append_Info_String (Name, Info, Ptr);
end;
@ -556,9 +556,9 @@ package body Exception_Data is
procedure Set_Exception_C_Msg
(Id : Exception_Id;
Msg1 : Big_String_Ptr;
Msg1 : System.Address;
Line : Integer := 0;
Msg2 : Big_String_Ptr := null)
Msg2 : System.Address := System.Null_Address)
is
Excep : constant EOA := Get_Current_Excep.all;
Val : Integer := Line;
@ -575,11 +575,11 @@ package body Exception_Data is
Excep.Msg_Length := 0;
Excep.Cleanup_Flag := False;
while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
end loop;
-- Append line number if present
@ -613,18 +613,18 @@ package body Exception_Data is
-- Append second message if present
if Msg2 /= null
if Msg2 /= System.Null_Address
and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
then
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := ' ';
Ptr := 1;
while Msg2 (Ptr) /= ASCII.NUL
while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
loop
Excep.Msg_Length := Excep.Msg_Length + 1;
Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
Ptr := Ptr + 1;
end loop;
end if;

362
gcc/ada/bindgen.adb
View File

@ -201,16 +201,6 @@ package body Bindgen is
procedure Gen_Elab_Defs_C;
-- Generate sequence of definitions for elaboration routines (C code case)
procedure Gen_Exception_Table_Ada;
-- Generate binder exception table (Ada code case). This consists of
-- declarations followed by a begin followed by a call. If zero cost
-- exceptions are not active, then only the begin is generated.
procedure Gen_Exception_Table_C;
-- Generate binder exception table (C code case). This has no effect
-- if zero cost exceptions are not active, otherwise it generates a
-- set of declarations followed by a call.
procedure Gen_Main_Ada;
-- Generate procedure main (Ada code case)
@ -279,9 +269,6 @@ package body Bindgen is
-- Set given character in Statement_Buffer at the Last + 1 position
-- and increment Last by one to reflect the stored character.
procedure Set_EA_Last;
-- Output the number of elements in array EA
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces
-- starting at the Last + 1 position, and updating Last past the value.
@ -296,7 +283,7 @@ package body Bindgen is
-- is generated starting at Last + 1, and Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
@ -550,10 +537,7 @@ package body Bindgen is
WBI (" Handler_Installed : Integer;");
WBI (" pragma Import (C, Handler_Installed, " &
"""__gnat_handler_installed"");");
-- Generate exception table
Gen_Exception_Table_Ada;
WBI (" begin");
-- Generate the call to Set_Globals
@ -782,10 +766,8 @@ package body Bindgen is
-- Code for normal case (standard library not suppressed)
Gen_Exception_Table_C;
-- Generate call to set the runtime global variables defined in
-- a-init.c. We define the varables in a-init.c, rather than in
-- init.c. We define the varables in init.c, rather than in
-- the binder generated file itself to avoid undefined externals
-- when the runtime is linked as a shareable image library.
@ -1228,324 +1210,6 @@ package body Bindgen is
WBI (" END ELABORATION ORDER */");
end Gen_Elab_Order_C;
-----------------------------
-- Gen_Exception_Table_Ada --
-----------------------------
procedure Gen_Exception_Table_Ada is
Num : Nat;
Last : ALI_Id := No_ALI_Id;
begin
if not Zero_Cost_Exceptions_Specified then
WBI (" begin");
return;
end if;
-- The code we generate looks like
-- procedure SDP_Table_Build
-- (SDP_Addresses : System.Address;
-- SDP_Count : Natural;
-- Elab_Addresses : System.Address;
-- Elab_Addr_Count : Natural);
-- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
--
-- ST : aliased constant array (1 .. nnn) of System.Address := (
-- unit_name_1'UET_Address,
-- unit_name_2'UET_Address,
-- ...
-- unit_name_3'UET_Address,
--
-- EA : aliased constant array (1 .. eee) of System.Address := (
-- adainit'Code_Address,
-- adafinal'Code_Address,
-- unit_name'elab[spec|body]'Code_Address,
-- unit_name'elab[spec|body]'Code_Address,
-- unit_name'elab[spec|body]'Code_Address,
-- unit_name'elab[spec|body]'Code_Address);
--
-- begin
-- SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
Num := 0;
for A in ALIs.First .. ALIs.Last loop
if not ALIs.Table (A).SAL_Interface
and then ALIs.Table (A).Unit_Exception_Table
then
Num := Num + 1;
Last := A;
end if;
end loop;
if Num = 0 then
-- Happens with "gnatmake -a -f -gnatL ..."
WBI (" ");
WBI (" begin");
return;
end if;
WBI (" procedure SDP_Table_Build");
WBI (" (SDP_Addresses : System.Address;");
WBI (" SDP_Count : Natural;");
WBI (" Elab_Addresses : System.Address;");
WBI (" Elab_Addr_Count : Natural);");
WBI (" " &
"pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
WBI (" ");
Set_String (" ST : aliased constant array (1 .. ");
Set_Int (Num);
Set_String (") of System.Address := (");
if Num = 1 then
Set_String ("1 => ");
else
Write_Statement_Buffer;
end if;
for A in ALIs.First .. ALIs.Last loop
if not ALIs.Table (A).SAL_Interface
and then ALIs.Table (A).Unit_Exception_Table
then
Get_Decoded_Name_String_With_Brackets
(Units.Table (ALIs.Table (A).First_Unit).Uname);
Set_Casing (Mixed_Case);
if Num /= 1 then
Set_String (" ");
end if;
Set_String (Name_Buffer (1 .. Name_Len - 2));
Set_String ("'UET_Address");
if A = Last then
Set_String (");");
else
Set_Char (',');
end if;
Write_Statement_Buffer;
end if;
end loop;
WBI (" ");
Set_String (" EA : aliased constant array (1 .. ");
Set_EA_Last;
Set_String (") of System.Address := (");
Write_Statement_Buffer;
Set_String (" " & Ada_Init_Name.all & "'Code_Address");
-- If compiling for the JVM, we directly reference Adafinal because
-- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
if not Cumulative_Restrictions.Set (No_Finalization) then
Set_Char (',');
Write_Statement_Buffer;
if Hostparm.Java_VM then
Set_String
(" System.Standard_Library.Adafinal'Code_Address");
else
Set_String
(" Do_Finalize'Code_Address");
end if;
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
Get_Decoded_Name_String_With_Brackets
(Units.Table (Elab_Order.Table (E)).Uname);
if Units.Table (Elab_Order.Table (E)).No_Elab then
null;
else
Set_Char (',');
Write_Statement_Buffer;
Set_String (" ");
if Name_Buffer (Name_Len) = 's' then
Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
"'elab_spec'code_address";
else
Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
"'elab_body'code_address";
end if;
Name_Len := Name_Len + 21;
Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
Set_Name_Buffer;
end if;
end loop;
Set_String (");");
Write_Statement_Buffer;
WBI (" ");
WBI (" begin");
Set_String (" SDP_Table_Build (ST'Address, ");
Set_Int (Num);
Set_String (", EA'Address, ");
Set_EA_Last;
Set_String (");");
Write_Statement_Buffer;
end Gen_Exception_Table_Ada;
---------------------------
-- Gen_Exception_Table_C --
---------------------------
procedure Gen_Exception_Table_C is
Num : Nat;
Num2 : Nat;
begin
if not Zero_Cost_Exceptions_Specified then
return;
end if;
-- The code we generate looks like
-- extern void *__gnat_unitname1__SDP;
-- extern void *__gnat_unitname2__SDP;
-- ...
--
-- void **st[nnn] = {
-- &__gnat_unitname1__SDP,
-- &__gnat_unitname2__SDP,
-- ...
-- &__gnat_unitnamen__SDP};
--
-- extern void unitname1__elabb ();
-- extern void unitname2__elabb ();
-- ...
--
-- void (*ea[eee]) () = {
-- adainit,
-- adafinal,
-- unitname1___elab[b,s],
-- unitname2___elab[b,s],
-- ...
-- unitnamen___elab[b,s]};
--
-- __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
Num := 0;
for A in ALIs.First .. ALIs.Last loop
if not ALIs.Table (A).SAL_Interface
and then ALIs.Table (A).Unit_Exception_Table
then
Num := Num + 1;
Set_String (" extern void *__gnat_");
Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
Set_Unit_Name;
Set_String ("__SDP");
Set_Char (';');
Write_Statement_Buffer;
end if;
end loop;
if Num = 0 then
-- Happens with "gnatmake -a -f -gnatL ..."
return;
end if;
WBI (" ");
Set_String (" void **st[");
Set_Int (Num);
Set_String ("] = {");
Write_Statement_Buffer;
Num2 := 0;
for A in ALIs.First .. ALIs.Last loop
if not ALIs.Table (A).SAL_Interface
and then ALIs.Table (A).Unit_Exception_Table
then
Num2 := Num2 + 1;
Set_String (" &__gnat_");
Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
Set_Unit_Name;
Set_String ("__SDP");
if Num = Num2 then
Set_String ("};");
else
Set_Char (',');
end if;
Write_Statement_Buffer;
end if;
end loop;
WBI ("");
for E in Elab_Order.First .. Elab_Order.Last loop
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
if Units.Table (Elab_Order.Table (E)).No_Elab then
null;
else
Set_String (" extern void ");
Set_Unit_Name;
Set_String ("___elab");
Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
Set_String (" ();");
Write_Statement_Buffer;
end if;
end loop;
WBI ("");
Set_String (" void (*ea[");
Set_EA_Last;
Set_String ("]) () = {");
Write_Statement_Buffer;
Set_String (" " & Ada_Init_Name.all);
if not Cumulative_Restrictions.Set (No_Finalization) then
Set_Char (',');
Write_Statement_Buffer;
Set_String (" system__standard_library__adafinal");
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
if Units.Table (Elab_Order.Table (E)).No_Elab then
null;
else
Set_Char (',');
Write_Statement_Buffer;
Set_String (" ");
Set_Unit_Name;
Set_String ("___elab");
Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
end if;
end loop;
Set_String ("};");
Write_Statement_Buffer;
WBI (" ");
Set_String (" __gnat_SDP_Table_Build (&st, ");
Set_Int (Num);
Set_String (", ea, ");
Set_EA_Last;
Set_String (");");
Write_Statement_Buffer;
end Gen_Exception_Table_C;
------------------
-- Gen_Main_Ada --
------------------
@ -1943,7 +1607,7 @@ package body Bindgen is
-- internal file appears.
procedure Write_Linker_Option;
-- Write binder info linker option.
-- Write binder info linker option
-------------------------
-- Write_Linker_Option --
@ -3132,24 +2796,6 @@ package body Bindgen is
Statement_Buffer (Last) := C;
end Set_Char;
-----------------
-- Set_EA_Last --
-----------------
procedure Set_EA_Last is
begin
-- When there is no finalization, only adainit is added
if Cumulative_Restrictions.Set (No_Finalization) then
Set_Int (Num_Elab_Calls + 1);
-- When there is finalization, both adainit and adafinal are added
else
Set_Int (Num_Elab_Calls + 2);
end if;
end Set_EA_Last;
-------------
-- Set_Int --
-------------

9
gcc/ada/debug.adb
View File

@ -89,7 +89,7 @@ package body Debug is
-- dU Enable garbage collection of unreachable entities
-- dV Enable viewing of all symbols in debugger
-- dW Disable warnings on calls for IN OUT parameters
-- dX Enable Frontend ZCX even when it is not supported
-- dX
-- dY Enable configurable run-time mode
-- dZ Generate listing showing the contents of the dispatch tables
@ -457,13 +457,6 @@ package body Debug is
-- task of transitioning incorrect legacy code, we provide this
-- undocumented feature for suppressing these warnings.
-- dX Enable frontend ZCX even when it is not supported. Equivalent to
-- -gnatZ but without verifying that System.Front_End_ZCX_Support
-- is set. This causes the front end to generate suitable tables
-- for ZCX handling even when the runtime cannot handle ZCX. This
-- is used for testing the front end for correct ZCX operation, and
-- in particular is useful for multi-target testing.
-- dY Enable configurable run-time mode, just as though the System file
-- had Configurable_Run_Time_Mode set to True. This is useful in
-- testing high integrity mode.

1156
gcc/ada/exp_ch11.adb
View File

File diff suppressed because it is too large Load Diff

55
gcc/ada/exp_ch11.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -41,9 +41,6 @@ package Exp_Ch11 is
-- See runtime routine Ada.Exceptions for full details on the format and
-- content of these tables.
procedure Initialize;
-- Initializes these data structures for a new main unit file
procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id);
-- Given a handled statement sequence, HSS, for which the At_End_Proc
-- field is set, and which currently has no exception handlers, this
@ -59,59 +56,9 @@ package Exp_Ch11 is
-- is also called to expand the special exception handler built for
-- accept bodies (see Exp_Ch9.Build_Accept_Body).
procedure Generate_Unit_Exception_Table;
-- Procedure called by main driver to generate unit exception table if
-- zero cost exceptions are enabled. See System.Exceptions for details.
function Is_Non_Ada_Error (E : Entity_Id) return Boolean;
-- This function is provided for Gigi use. It returns True if operating on
-- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error.
-- This is used to generate the special matching code for this exception.
procedure Remove_Handler_Entries (N : Node_Id);
-- This procedure is called when optimization circuits determine that
-- an entire subtree can be removed. If the subtree contains handler
-- entries in zero cost exception mode, then such removal can lead to
-- dangling references to non-existent handlers in the handler table.
-- This procedure removes such references.
--------------------------------------
-- Subprogram_Descriptor Generation --
--------------------------------------
-- Subprogram descriptors are required for all subprograms, including
-- explicit subprograms defined in the program, subprograms that are
-- imported via pragma Import, and also for the implicit elaboration
-- subprograms used to elaborate package specs and bodies.
procedure Generate_Subprogram_Descriptor_For_Package
(N : Node_Id;
Spec : Entity_Id);
-- This is used to create a descriptor for the implicit elaboration
-- procedure for a package spec of body. The compiler only generates
-- such descriptors if the package spec or body contains exception
-- handlers (either explicitly in the case of a body, or from generic
-- package instantiations). N is the node for the package body or
-- spec, and Spec is the package body or package entity respectively.
-- N must be a compilation unit, and the descriptor is placed at
-- the end of the actions for the auxiliary compilation unit node.
procedure Generate_Subprogram_Descriptor_For_Subprogram
(N : Node_Id;
Spec : Entity_Id);
-- This is used to create a desriptor for a subprogram, both those
-- present in the source, and those implicitly generated by code
-- expansion. N is the subprogram body node, and Spec is the entity
-- for the subprogram. The descriptor is placed at the end of the
-- Last exception handler, or, if there are no handlers, at the end
-- of the statement sequence.
procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
(Spec : Entity_Id;
Slist : List_Id);
-- This is used to create a descriptor for an imported subprogram.
-- Such descriptors are needed for propagation of exceptions through
-- such subprograms. The descriptor never references any handlers,
-- and is appended to the given Slist.
end Exp_Ch11;

4
gcc/ada/freeze.adb
View File

@ -30,7 +30,6 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
@ -3365,9 +3364,6 @@ package body Freeze is
if Result = No_List then
Result := Empty_List;
end if;
Generate_Subprogram_Descriptor_For_Imported_Subprogram
(E, Result);
end if;
end if;

9
gcc/ada/frontend.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -31,7 +31,6 @@ with Checks;
with CStand;
with Debug; use Debug;
with Elists;
with Exp_Ch11;
with Exp_Dbug;
with Fmap;
with Fname.UF;
@ -80,7 +79,6 @@ begin
Lib.Load.Initialize;
Sem_Ch8.Initialize;
Fname.UF.Initialize;
Exp_Ch11.Initialize;
Checks.Initialize;
-- Create package Standard
@ -329,11 +327,6 @@ begin
end if;
Check_Elab_Calls;
-- Build unit exception table. We leave this up to the end to
-- make sure that all the necessary information is at hand.
Exp_Ch11.Generate_Unit_Exception_Table;
end if;
-- List library units if requested

22
gcc/ada/gnat1drv.adb
View File

@ -203,27 +203,7 @@ begin
if Targparm.ZCX_By_Default_On_Target then
if Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_ZCX_Exceptions;
else
Exception_Mechanism := Front_End_ZCX_Exceptions;
end if;
end if;
-- We take the command line exception mechanism into account
if Opt.Zero_Cost_Exceptions_Set then
if Opt.Zero_Cost_Exceptions_Val = False then
Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions;
elsif Debug_Flag_XX then
Exception_Mechanism := Front_End_ZCX_Exceptions;
elsif Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_ZCX_Exceptions;
elsif Targparm.Front_End_ZCX_Support_On_Target then
Exception_Mechanism := Front_End_ZCX_Exceptions;
Exception_Mechanism := Back_End_Exceptions;
else
Osint.Fail
("Zero Cost Exceptions not supported on this target");

26
gcc/ada/inline.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
@ -986,29 +985,6 @@ package body Inline is
and then not Is_Generic_Unit (Main_Unit_Entity)
then
Cleanup_Scopes;
-- Also generate subprogram descriptors that were delayed
for J in Pending_Descriptor.First .. Pending_Descriptor.Last loop
declare
Ent : constant Entity_Id := Pending_Descriptor.Table (J);
begin
if Is_Subprogram (Ent) then
Generate_Subprogram_Descriptor_For_Subprogram
(Get_Subprogram_Body (Ent), Ent);
elsif Ekind (Ent) = E_Package then
Generate_Subprogram_Descriptor_For_Package
(Parent (Declaration_Node (Ent)), Ent);
elsif Ekind (Ent) = E_Package_Body then
Generate_Subprogram_Descriptor_For_Package
(Declaration_Node (Ent), Ent);
end if;
end;
end loop;
elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
End_Generic;
end if;

10
gcc/ada/lib-writ.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -63,7 +63,7 @@ package Lib.Writ is
-- If the following guidelines are respected, downward compatibility
-- problems (old tools reading new ali files) should be minimized:
-- The basic key character format must be kept.
-- The basic key character format must be kept
-- The V line must be the first line, this is checked by ali.adb
-- even in Ignore_Errors mode, and is used to verify that the file
@ -233,10 +233,6 @@ package Lib.Writ is
-- UA Unreserve_All_Interrupts pragma was processed in one or
-- more units in this file
--
-- UX Generated code contains unit exception table pointer
-- (i.e. it uses zero-cost exceptions, and there is at
-- least one subprogram present).
--
-- ZX Units in this file use zero-cost exceptions and have
-- generated exception tables. If ZX is not present, the
-- longjmp/setjmp exception scheme is in use.
@ -390,7 +386,7 @@ package Lib.Writ is
-- -- U Unit Header --
-- --------------------
-- The lines for each compilation unit have the following form.
-- The lines for each compilation unit have the following form
-- U unit-name source-name version <<attributes>>
--

4
gcc/ada/lib.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -39,7 +39,6 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Fname; use Fname;
with Namet; use Namet;
with Namet; use Namet;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@ -827,7 +826,6 @@ package body Lib is
Linker_Option_Lines.Init;
Load_Stack.Init;
Units.Init;
Unit_Exception_Table_Present := False;
Compilation_Switches.Init;
end Initialize;

8
gcc/ada/raise.h
View File

@ -31,16 +31,18 @@
****************************************************************************/
/* C counterparts of what System.Standard_Library defines. */
typedef unsigned Exception_Code;
/* C counterpart of what System.Standard_Library defines. */
struct Exception_Data
{
char Handled_By_Others;
char Not_Handled_By_Others;
char Lang;
int Name_Length;
char *Full_Name, Htable_Ptr;
char *Full_Name, *Htable_Ptr;
Exception_Code Import_Code;
void (*Raise_Hook)(void);
};
typedef struct Exception_Data *Exception_Id;

203
gcc/ada/s-except.ads
View File

@ -1,203 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . E X C E P T I O N S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2000 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, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains definitions used for zero cost exception handling.
-- See unit Ada.Exceptions for further details. Note that the reason that
-- we separate out these definitions is to avoid problems with recursion
-- in rtsfind. They must be in a unit which does not require any exception
-- table generation of any kind.
with Ada.Exceptions;
with System;
with System.Standard_Library;
with Unchecked_Conversion;
package System.Exceptions is
package SSL renames System.Standard_Library;
package AEX renames Ada.Exceptions;
-- The following section defines data structures used for zero cost
-- exception handling if System.Parameters.Zero_Cost_Exceptions is
-- set true (i.e. zero cost exceptions are implemented on this target).
-- The approach is to build tables that describe the PC ranges that
-- are covered by various exception frames. When an exception occurs,
-- these tables are searched to determine the address of the applicable
-- handler for the current exception.
subtype Handler_Loc is System.Address;
-- Code location representing entry address of a handler. Values of
-- this type are created using the N_Handler_Loc node, and then
-- passed to the Enter_Handler procedure to enter a handler.
subtype Code_Loc is System.Address;
-- Code location used in building exception tables and for call
-- addresses when propagating an exception (also traceback table)
-- Values of this type are created by using Label'Address or
-- extracted from machine states using Get_Code_Loc.
--------------------
-- Handler_Record --
--------------------
-- A Handler record is built for each choice for each exception handler
-- in a frame.
function To_Exception_Id is
new Unchecked_Conversion (SSL.Exception_Data_Ptr, AEX.Exception_Id);
Others_Dummy_Exception : aliased SSL.Exception_Data;
Others_Id : constant AEX.Exception_Id :=
To_Exception_Id (Others_Dummy_Exception'Access);
-- Dummy exception used to signal others exception
All_Others_Dummy_Exception : aliased SSL.Exception_Data;
All_Others_Id : constant AEX.Exception_Id :=
To_Exception_Id (All_Others_Dummy_Exception'Access);
-- Dummy exception used to signal all others exception (including
-- exceptions not normally handled by others, e.g. Abort_Signal)
type Handler_Record is record
Lo : Code_Loc;
Hi : Code_Loc;
-- Range of PC values of code covered by this handler record. The
-- handler covers all code addresses that are greater than the Lo
-- value, and less than or equal to the Hi value.
Id : AEX.Exception_Id;
-- Id of exception being handled, or one of the above special values
Handler : Handler_Loc;
-- Address of label at start of handler
end record;
type Handler_Record_Ptr is access all Handler_Record;
type Handler_Record_List is array (Natural range <>) of Handler_Record_Ptr;
---------------------------
-- Subprogram_Descriptor --
---------------------------
-- A Subprogram_Descriptor is built for each subprogram through which
-- exceptions may propagate, this includes all Ada subprograms,
-- and also all foreign language imported subprograms.
subtype Subprogram_Info_Type is System.Address;
-- This type is used to represent a value that is used to unwind stack
-- frames. It references target dependent data that provides sufficient
-- information (e.g. about the location of the return point, use of a
-- frame pointer, save-over-call registers etc) to unwind the machine
-- state to the caller. For some targets, this is simply a pointer to
-- the entry point of the procedure (and the routine to pop the machine
-- state disassembles the code at the entry point to obtain the required
-- information). On other targets, it is a pointer to data created by the
-- backend or assembler to represent the required information.
No_Info : constant Subprogram_Info_Type := System.Null_Address;
-- This is a special value used to indicate that it is not possible
-- to pop past this frame. This is used at the outer level (e.g. for
-- package elaboration procedures or the main procedure), and for any
-- other foreign language procedure for which propagation is known
-- to be impossible. An exception is considered unhandled if an
-- attempt is made to pop a frame whose Subprogram_Info_Type value
-- is set to No_Info.
type Subprogram_Descriptor (Num_Handlers : Natural) is record
Code : Code_Loc;
-- This is a code location used to determine which procedure we are
-- in. Most usually it is simply the entry address for the procedure.
-- hA given address is considered to be within the procedure referenced
-- by a Subprogram_Descriptor record if this is the descriptor for
-- which the Code value is as large as possible without exceeding
-- the given value.
Subprogram_Info : Subprogram_Info_Type;
-- This is a pointer to a target dependent data item that provides
-- sufficient information for unwinding the stack frame of this
-- procedure. A value of No_Info (zero) means that we are the
-- outer level procedure.
Handler_Records : Handler_Record_List (1 .. Num_Handlers);
-- List of pointers to Handler_Records for this procedure. The array
-- is sorted inside out, i.e. entries for inner frames appear before
-- entries for outer handlers. This ensures that a serial search
-- finds the innermost applicable handler
end record;
subtype Subprogram_Descriptor_0 is Subprogram_Descriptor (0);
subtype Subprogram_Descriptor_1 is Subprogram_Descriptor (1);
subtype Subprogram_Descriptor_2 is Subprogram_Descriptor (2);
subtype Subprogram_Descriptor_3 is Subprogram_Descriptor (3);
-- Predeclare commonly used subtypes for buildingt he tables
type Subprogram_Descriptor_Ptr is access all Subprogram_Descriptor;
type Subprogram_Descriptor_List
is array (Natural range <>) of Subprogram_Descriptor_Ptr;
type Subprogram_Descriptors_Record (Count : Natural) is record
SDesc : Subprogram_Descriptor_List (1 .. Count);
end record;
type Subprogram_Descriptors_Ptr is
access all Subprogram_Descriptors_Record;
--------------------------
-- Unit Exception_Table --
--------------------------
-- If a unit contains at least one subprogram, then a library level
-- declaration of the form:
-- Tnn : aliased constant Subprogram_Descriptors :=
-- (Count => n,
-- SDesc =>
-- (SD1'Unrestricted_Access,
-- SD2'Unrestricted_Access,
-- ...
-- SDn'Unrestricted_Access));
-- pragma Export (Ada, Tnn, "__gnat_unit_name__SDP");
-- is generated where the initializing expression is an array aggregate
-- whose elements are pointers to the generated subprogram descriptors
-- for the units.
-- Note: the ALI file contains the designation UX in each unit entry
-- if a unit exception table is generated.
-- The binder generates a list of addresses of pointers to these tables.
end System.Exceptions;

84
gcc/ada/s-mastop-irix.adb
View File

@ -44,7 +44,6 @@ with Unchecked_Conversion;
package body System.Machine_State_Operations is
use System.Storage_Elements;
use System.Exceptions;
-- The exc_unwind function in libexc operats on a Sigcontext
@ -182,66 +181,6 @@ package body System.Machine_State_Operations is
(Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements));
end Allocate_Machine_State;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
pragma Warnings (Off, M);
pragma Warnings (Off, Handler);
LOADI : constant String (1 .. 2) := 'l' & LSC;
-- This is "lw" in o32 mode, and "ld" in n32/n64 mode
LOADF : constant String (1 .. 4) := 'l' & LSC & "c1";
-- This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode
begin
-- Restore integer registers from machine state. Note that we know
-- that $4 points to M, and $5 points to Handler, since this is
-- the standard calling sequence
Asm (LOADI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
Asm (LOADI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
-- Restore floating-point registers from machine state
Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
-- Jump directly to the handler
Asm ("jr $5");
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
@ -284,12 +223,7 @@ package body System.Machine_State_Operations is
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type)
is
pragma Warnings (Off, Info);
procedure Pop_Frame (M : Machine_State) is
Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);
procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
@ -407,21 +341,7 @@ package body System.Machine_State_Operations is
-- This pop operation will properly set the PC value in the machine
-- state, so there is no need to save PC in the above code.
Pop_Frame (M, Set_Machine_State'Address);
Pop_Frame (M);
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address)
is
pragma Warnings (Off, M);
pragma Warnings (Off, Context);
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;

37
gcc/ada/s-mastop-tru64.adb
View File

@ -39,8 +39,6 @@ with System.Memory;
package body System.Machine_State_Operations is
use System.Exceptions;
pragma Linker_Options ("-lexc");
-- Needed for definitions of exc_capture_context and exc_virtual_unwind
@ -59,18 +57,6 @@ package body System.Machine_State_Operations is
(Memory.Alloc (Memory.size_t (c_machine_state_length)));
end Allocate_Machine_State;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc);
pragma Import (C, c_enter_handler, "__gnat_enter_handler");
begin
c_enter_handler (M, Handler);
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
@ -135,12 +121,7 @@ package body System.Machine_State_Operations is
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type)
is
pragma Warnings (Off, Info);
procedure Pop_Frame (M : Machine_State) is
procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State);
pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind");
@ -178,21 +159,7 @@ package body System.Machine_State_Operations is
pragma Import (C, c_capture_context, "exc_capture_context");
begin
c_capture_context (M);
Pop_Frame (M, System.Null_Address);
Pop_Frame (M);
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address)
is
pragma Warnings (Off, M);
pragma Warnings (Off, Context);
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;

64
gcc/ada/s-mastop-vms.adb
View File

@ -41,7 +41,6 @@ with Unchecked_Conversion;
package body System.Machine_State_Operations is
use System.Exceptions;
subtype Cond_Value_Type is Unsigned_Longword;
-- Record layouts copied from Starlet.
@ -148,48 +147,6 @@ package body System.Machine_State_Operations is
(Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
end Allocate_Machine_State;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
procedure Get_Invo_Context (
Result : out Unsigned_Longword; -- return value
Invo_Handle : Invo_Handle_Type;
Invo_Context : out Invo_Context_Blk_Type);
pragma Interface (External, Get_Invo_Context);
pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
(Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
(Value, Value, Reference));
ICB : Invo_Context_Blk_Type;
procedure Goto_Unwind (
Status : out Cond_Value_Type; -- return value
Target_Invo : Address := Address_Zero;
Target_PC : Address := Address_Zero;
New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter;
New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter);
pragma Interface (External, Goto_Unwind);
pragma Import_Valued_Procedure
(Goto_Unwind, "SYS$GOTO_UNWIND",
(Cond_Value_Type, Address, Address,
Unsigned_Quadword, Unsigned_Quadword),
(Value, Reference, Reference,
Reference, Reference));
Status : Cond_Value_Type;
begin
Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
Goto_Unwind
(Status, System.Address (To_Invo_Handle_Access (M).all), Handler);
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
@ -261,12 +218,7 @@ package body System.Machine_State_Operations is
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type)
is
pragma Warnings (Off, Info);
procedure Pop_Frame (M : Machine_State) is
procedure Get_Prev_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
ICB : in Invo_Handle_Type);
@ -321,18 +273,4 @@ package body System.Machine_State_Operations is
Pop_Frame (M, System.Null_Address);
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address)
is
pragma Warnings (Off, M);
pragma Warnings (Off, Context);
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;

594
gcc/ada/s-mastop-x86.adb
View File

@ -1,594 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- SYSTEM.MACHINE_STATE_OPERATIONS --
-- --
-- B o d y --
-- (Version for x86) --
-- --
-- Copyright (C) 1999-2004 Ada Core Technologies, 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, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Note: it is very important that this unit not generate any exception
-- tables of any kind. Otherwise we get a nasty rtsfind recursion problem.
-- This means no subprograms, including implicitly generated ones.
with Unchecked_Conversion;
with System.Storage_Elements;
with System.Machine_Code; use System.Machine_Code;
with System.Memory;
package body System.Machine_State_Operations is
function "+" (Left, Right : Address) return Address;
pragma Import (Intrinsic, "+");
-- Provide addition operation on type Address (this may not be directly
-- available if type System.Address is non-private and the operations on
-- the type are made abstract to hide them from public users of System).
use System.Exceptions;
type Uns8 is mod 2 ** 8;
type Uns32 is mod 2 ** 32;
type Bits5 is mod 2 ** 5;
type Bits6 is mod 2 ** 6;
function To_Address is new Unchecked_Conversion (Uns32, Address);
type Uns32_Ptr is access all Uns32;
function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr);
-- Note: the type Uns32 has an alignment of 4. However, in some cases
-- values of type Uns32_Ptr will not be aligned (notably in the case
-- where we get the immediate field from an instruction). However this
-- does not matter in practice, since the x86 does not require that
-- operands be aligned.
----------------------
-- General Approach --
----------------------
-- For the x86 version of this unit, the Subprogram_Info_Type values
-- are simply the starting code address for the subprogram. Popping
-- of stack frames works by analyzing the code in the prolog, and
-- deriving from this analysis the necessary information for restoring
-- the registers, including the return point.
---------------------------
-- Description of Prolog --
---------------------------
-- If a frame pointer is present, the prolog looks like
-- pushl %ebp
-- movl %esp,%ebp
-- subl $nnn,%esp omitted if nnn = 0
-- pushl %edi omitted if edi not used
-- pushl %esi omitted if esi not used
-- pushl %ebx omitted if ebx not used
-- If a frame pointer is not present, the prolog looks like
-- subl $nnn,%esp omitted if nnn = 0
-- pushl %ebp omitted if ebp not used
-- pushl %edi omitted if edi not used
-- pushl %esi omitted if esi not used
-- pushl %ebx omitted if ebx not used
-- Note: any or all of the save over call registers may be used and
-- if so, will be saved using pushl as shown above. The order of the
-- pushl instructions will be as shown above for gcc generated code,
-- but the code in this unit does not assume this.
-------------------------
-- Description of Call --
-------------------------
-- A call looks like:
-- pushl ... push parameters
-- pushl ...
-- call ... perform the call
-- addl $nnn,%esp omitted if no parameters
-- Note that we are not absolutely guaranteed that the call is always
-- followed by an addl operation that readjusts %esp for this particular
-- call. There are two reasons for this:
-- 1) The addl can be delayed and combined in the case where more than
-- one call appears in sequence. This can be suppressed by using the
-- switch -fno-defer-pop and for Ada code, we automatically use
-- this switch, but we could still be dealing with C code that was
-- compiled without using this switch.
-- 2) Scheduling may result in moving the addl instruction away from
-- the call. It is not clear if this actually can happen at the
-- current time, but it is certainly conceptually possible.
-- The addl after the call is important, since we need to be able to
-- restore the proper %esp value when we pop the stack. However, we do
-- not try to compensate for either of the above effects. As noted above,
-- case 1 does not occur for Ada code, and it does not appear in practice
-- that case 2 occurs with any significant frequency (we have never seen
-- an example so far for gcc generated code).
-- Furthermore, it is only in the case of -fomit-frame-pointer that we
-- really get into trouble from not properly restoring %esp. If we have
-- a frame pointer, then the worst that happens is that %esp is slightly
-- more depressed than it should be. This could waste a bit of space on
-- the stack, and even in some cases cause a storage leak on the stack,
-- but it will not affect the functional correctness of the processing.
----------------------------------------
-- Definitions of Instruction Formats --
----------------------------------------
type Rcode is (eax, ecx, edx, ebx, esp, ebp, esi, edi);
pragma Warnings (Off, Rcode);
-- Code indicating which register is referenced in an instruction
-- The following define the format of a pushl instruction
Op_pushl : constant Bits5 := 2#01010#;
type Ins_pushl is record
Op : Bits5 := Op_pushl;
Reg : Rcode;
end record;
for Ins_pushl use record
Op at 0 range 3 .. 7;
Reg at 0 range 0 .. 2;
end record;
Ins_pushl_ebp : constant Ins_pushl := (Op_pushl, Reg => ebp);
type Ins_pushl_Ptr is access all Ins_pushl;
-- For the movl %esp,%ebp instruction, we only need to know the length
-- because we simply skip past it when we analyze the prolog.
Ins_movl_length : constant := 2;
-- The following define the format of addl/subl esp instructions
Op_Immed : constant Bits6 := 2#100000#;
Op2_addl_Immed : constant Bits5 := 2#11100#;
pragma Unreferenced (Op2_addl_Immed);
Op2_subl_Immed : constant Bits5 := 2#11101#;
type Word_Byte is (Word, Byte);
pragma Unreferenced (Byte);
type Ins_addl_subl_byte is record
Op : Bits6; -- Set to Op_Immed
w : Word_Byte; -- Word/Byte flag (set to 1 = byte)
s : Boolean; -- Sign extension bit (1 = extend)
Op2 : Bits5; -- Secondary opcode
Reg : Rcode; -- Register
Imm8 : Uns8; -- Immediate operand
end record;
for Ins_addl_subl_byte use record
Op at 0 range 2 .. 7;
w at 0 range 1 .. 1;
s at 0 range 0 .. 0;
Op2 at 1 range 3 .. 7;
Reg at 1 range 0 .. 2;
Imm8 at 2 range 0 .. 7;
end record;
type Ins_addl_subl_word is record
Op : Bits6; -- Set to Op_Immed
w : Word_Byte; -- Word/Byte flag (set to 0 = word)
s : Boolean; -- Sign extension bit (1 = extend)
Op2 : Bits5; -- Secondary opcode
Reg : Rcode; -- Register
Imm32 : Uns32; -- Immediate operand
end record;
for Ins_addl_subl_word use record
Op at 0 range 2 .. 7;
w at 0 range 1 .. 1;
s at 0 range 0 .. 0;
Op2 at 1 range 3 .. 7;
Reg at 1 range 0 .. 2;
Imm32 at 2 range 0 .. 31;
end record;
type Ins_addl_subl_byte_Ptr is access all Ins_addl_subl_byte;
type Ins_addl_subl_word_Ptr is access all Ins_addl_subl_word;
---------------------
-- Prolog Analysis --
---------------------
-- The analysis of the prolog answers the following questions:
-- 1. Is %ebp used as a frame pointer?
-- 2. How far is SP depressed (i.e. what is the stack frame size)
-- 3. Which registers are saved in the prolog, and in what order
-- The following data structure stores the answers to these questions
subtype SOC is Rcode range ebx .. edi;
-- Possible save over call registers
SOC_Max : constant := 4;
-- Max number of SOC registers that can be pushed
type SOC_Push_Regs_Type is array (1 .. 4) of Rcode;
-- Used to hold the register codes of pushed SOC registers
type Prolog_Type is record
Frame_Reg : Boolean;
-- This is set to True if %ebp is used as a frame register, and
-- False otherwise (in the False case, %ebp may be saved in the
-- usual manner along with the other SOC registers).
Frame_Length : Uns32;
-- Amount by which ESP is decremented on entry, includes the effects
-- of push's of save over call registers as indicated above, e.g. if
-- the prolog of a routine is:
--
-- pushl %ebp
-- movl %esp,%ebp
-- subl $424,%esp
-- pushl %edi
-- pushl %esi
-- pushl %ebx
--
-- Then the value of Frame_Length would be 436 (424 + 3 * 4). A
-- precise definition is that it is:
--
-- %esp on entry minus %esp after last SOC push
--
-- That definition applies both in the frame pointer present and
-- the frame pointer absent cases.
Num_SOC_Push : Integer range 0 .. SOC_Max;
-- Number of save over call registers actually saved by pushl
-- instructions (other than the initial pushl to save the frame
-- pointer if a frame pointer is in use).
SOC_Push_Regs : SOC_Push_Regs_Type;
-- The First Num_SOC_Push entries of this array are used to contain
-- the codes for the SOC registers, in the order in which they were
-- pushed. Note that this array excludes %ebp if it is used as a frame
-- register, since although %ebp is still considered an SOC register
-- in this case, it is saved and restored by a separate mechanism.
-- Also we will never see %esp represented in this list. Again, it is
-- true that %esp is saved over call, but it is restored by a separate
-- mechanism.
end record;
procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type);
-- Given the address of the start of the prolog for a procedure,
-- analyze the instructions of the prolog, and set Prolog to contain
-- the information obtained from this analysis.
----------------------------------
-- Machine_State_Representation --
----------------------------------
-- The type Machine_State is defined in the body of Ada.Exceptions as
-- a Storage_Array of length 1 .. Machine_State_Length. But really it
-- has structure as defined here. We use the structureless declaration
-- in Ada.Exceptions to avoid this unit from being implementation
-- dependent. The actual definition of Machine_State is as follows:
type SOC_Regs_Type is array (SOC) of Uns32;
type MState is record
eip : Uns32;
-- The instruction pointer location (which is the return point
-- value from the next level down in all cases).
Regs : SOC_Regs_Type;
-- Values of the save over call registers
end record;
for MState use record
eip at 0 range 0 .. 31;
Regs at 4 range 0 .. 5 * 32 - 1;
end record;
-- Note: the routines Enter_Handler, and Set_Machine_State reference
-- the fields in this structure non-symbolically.
type MState_Ptr is access all MState;
function To_MState_Ptr is
new Unchecked_Conversion (Machine_State, MState_Ptr);
----------------------------
-- Allocate_Machine_State --
----------------------------
function Allocate_Machine_State return Machine_State is
use System.Storage_Elements;
begin
return Machine_State
(Memory.Alloc (MState'Max_Size_In_Storage_Elements));
end Allocate_Machine_State;
--------------------
-- Analyze_Prolog --
--------------------
procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type) is
Ptr : Address;
Ppl : Ins_pushl_Ptr;
Pas : Ins_addl_subl_byte_Ptr;
function To_Ins_pushl_Ptr is
new Unchecked_Conversion (Address, Ins_pushl_Ptr);
function To_Ins_addl_subl_byte_Ptr is
new Unchecked_Conversion (Address, Ins_addl_subl_byte_Ptr);
function To_Ins_addl_subl_word_Ptr is
new Unchecked_Conversion (Address, Ins_addl_subl_word_Ptr);
begin
Ptr := A;
Prolog.Frame_Length := 0;
if Ptr = Null_Address then
Prolog.Num_SOC_Push := 0;
Prolog.Frame_Reg := True;
return;
end if;
if To_Ins_pushl_Ptr (Ptr).all = Ins_pushl_ebp then
Ptr := Ptr + 1 + Ins_movl_length;
Prolog.Frame_Reg := True;
else
Prolog.Frame_Reg := False;
end if;
Pas := To_Ins_addl_subl_byte_Ptr (Ptr);
if Pas.Op = Op_Immed
and then Pas.Op2 = Op2_subl_Immed
and then Pas.Reg = esp
then
if Pas.w = Word then
Prolog.Frame_Length := Prolog.Frame_Length +
To_Ins_addl_subl_word_Ptr (Ptr).Imm32;
Ptr := Ptr + 6;
else
Prolog.Frame_Length := Prolog.Frame_Length + Uns32 (Pas.Imm8);
Ptr := Ptr + 3;
-- Note: we ignore sign extension, since a sign extended
-- value that was negative would imply a ludicrous frame size.
end if;
end if;
-- Now scan push instructions for SOC registers
Prolog.Num_SOC_Push := 0;
loop
Ppl := To_Ins_pushl_Ptr (Ptr);
if Ppl.Op = Op_pushl and then Ppl.Reg in SOC then
Prolog.Num_SOC_Push := Prolog.Num_SOC_Push + 1;
Prolog.SOC_Push_Regs (Prolog.Num_SOC_Push) := Ppl.Reg;
Prolog.Frame_Length := Prolog.Frame_Length + 4;
Ptr := Ptr + 1;
else
exit;
end if;
end loop;
end Analyze_Prolog;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
begin
Asm ("mov %0,%%edx", Inputs => Machine_State'Asm_Input ("r", M));
Asm ("mov %0,%%eax", Inputs => Handler_Loc'Asm_Input ("r", Handler));
Asm ("mov 4(%%edx),%%ebx"); -- M.Regs (ebx)
Asm ("mov 12(%%edx),%%ebp"); -- M.Regs (ebp)
Asm ("mov 16(%%edx),%%esi"); -- M.Regs (esi)
Asm ("mov 20(%%edx),%%edi"); -- M.Regs (edi)
Asm ("mov 8(%%edx),%%esp"); -- M.Regs (esp)
Asm ("jmp %*%%eax");
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
function Fetch_Code (Loc : Code_Loc) return Code_Loc is
begin
return Loc;
end Fetch_Code;
------------------------
-- Free_Machine_State --
------------------------
procedure Free_Machine_State (M : in out Machine_State) is
begin
Memory.Free (Address (M));
M := Machine_State (Null_Address);
end Free_Machine_State;
------------------
-- Get_Code_Loc --
------------------
function Get_Code_Loc (M : Machine_State) return Code_Loc is
Asm_Call_Size : constant := 2;
-- Minimum size for a call instruction under ix86. Using the minimum
-- size is safe here as the call point computed from the return point
-- will always be inside the call instruction.
MS : constant MState_Ptr := To_MState_Ptr (M);
begin
if MS.eip = 0 then
return To_Address (MS.eip);
else
-- When doing a call the return address is pushed to the stack.
-- We want to return the call point address, so we subtract
-- Asm_Call_Size from the return address. This value is set
-- to 5 as an asm call takes 5 bytes on x86 architectures.
return To_Address (MS.eip - Asm_Call_Size);
end if;
end Get_Code_Loc;
--------------------------
-- Machine_State_Length --
--------------------------
function Machine_State_Length
return System.Storage_Elements.Storage_Offset
is
begin
return MState'Max_Size_In_Storage_Elements;
end Machine_State_Length;
---------------
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type)
is
MS : constant MState_Ptr := To_MState_Ptr (M);
PL : Prolog_Type;
SOC_Ptr : Uns32;
-- Pointer to stack location after last SOC push
Rtn_Ptr : Uns32;
-- Pointer to stack location containing return address
begin
Analyze_Prolog (Info, PL);
-- Case of frame register, use EBP, safer than ESP
if PL.Frame_Reg then
SOC_Ptr := MS.Regs (ebp) - PL.Frame_Length;
Rtn_Ptr := MS.Regs (ebp) + 4;
MS.Regs (ebp) := To_Uns32_Ptr (MS.Regs (ebp)).all;
-- No frame pointer, use ESP, and hope we have it exactly right!
else
SOC_Ptr := MS.Regs (esp);
Rtn_Ptr := SOC_Ptr + PL.Frame_Length;
end if;
-- Get saved values of SOC registers
for J in reverse 1 .. PL.Num_SOC_Push loop
MS.Regs (PL.SOC_Push_Regs (J)) := To_Uns32_Ptr (SOC_Ptr).all;
SOC_Ptr := SOC_Ptr + 4;
end loop;
MS.eip := To_Uns32_Ptr (Rtn_Ptr).all;
MS.Regs (esp) := Rtn_Ptr + 4;
end Pop_Frame;
-----------------------
-- Set_Machine_State --
-----------------------
procedure Set_Machine_State (M : Machine_State) is
N : constant Asm_Output_Operand := No_Output_Operands;
begin
Asm ("mov %0,%%edx", N, Machine_State'Asm_Input ("r", M));
-- At this stage, we have the following situation (note that we
-- are assuming that the -fomit-frame-pointer switch has not been
-- used in compiling this procedure.
-- (value of M)
-- return point
-- old ebp <------ current ebp/esp value
-- The values of registers ebx/esi/edi are unchanged from entry
-- so they have the values we want, and %edx points to the parameter
-- value M, so we can store these values directly.
Asm ("mov %%ebx,4(%%edx)"); -- M.Regs (ebx)
Asm ("mov %%esi,16(%%edx)"); -- M.Regs (esi)
Asm ("mov %%edi,20(%%edx)"); -- M.Regs (edi)
-- The desired value of ebp is the old value
Asm ("mov 0(%%ebp),%%eax");
Asm ("mov %%eax,12(%%edx)"); -- M.Regs (ebp)
-- The return point is the desired eip value
Asm ("mov 4(%%ebp),%%eax");
Asm ("mov %%eax,(%%edx)"); -- M.eip
-- Finally, the desired %esp value is the value at the point of
-- call to this routine *before* pushing the parameter value.
Asm ("lea 12(%%ebp),%%eax");
Asm ("mov %%eax,8(%%edx)"); -- M.Regs (esp)
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address)
is
pragma Warnings (Off, M);
pragma Warnings (Off, Context);
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;

29
gcc/ada/s-mastop.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- (Dummy version) --
-- --
-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1999-2005 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- --
@ -41,8 +41,6 @@ package body System.Machine_State_Operations is
pragma Warnings (Off);
use System.Exceptions;
----------------------------
-- Allocate_Machine_State --
----------------------------
@ -52,15 +50,6 @@ package body System.Machine_State_Operations is
return Machine_State (Null_Address);
end Allocate_Machine_State;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
begin
null;
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
@ -102,9 +91,7 @@ package body System.Machine_State_Operations is
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type) is
procedure Pop_Frame (M : Machine_State) is
begin
null;
end Pop_Frame;
@ -118,16 +105,4 @@ package body System.Machine_State_Operations is
null;
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address)
is
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;

69
gcc/ada/s-mastop.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1999-2005 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- --
@ -36,7 +36,6 @@ pragma Polling (Off);
-- elaboration circularities with System.Exception_Tables.
with System.Storage_Elements;
with System.Exceptions;
package System.Machine_State_Operations is
@ -79,65 +78,11 @@ package System.Machine_State_Operations is
-- outer level, or some other frame for which no information can be
-- provided.
procedure Pop_Frame
(M : Machine_State;
Info : System.Exceptions.Subprogram_Info_Type);
procedure Pop_Frame (M : Machine_State);
-- This procedure pops the machine state M so that it represents the
-- call point, as though the current subprogram had returned. It
-- changes only the value referenced by M, and does not affect
-- the current stack environment.
--
-- The Info parameter represents information generated by the backend
-- (see description of Subprogram_Info node in sinfo.ads). This
-- information is stored as static data during compilation. The
-- caller then passes this information to Pop_Frame, which will
-- use it to determine what must be changed in the machine state
-- (e.g. which save-over-call registers must be restored, and from
-- where on the stack frame they must be restored).
--
-- A value of No_Info for Info means either that the backend provided
-- no information for current frame, or that the current frame is an
-- other language frame for which no information exists, or that this
-- is an outer level subprogram. In any case, Pop_Frame sets the code
-- location to Null_Address when it pops past such a frame, and this
-- is taken as an indication that the exception is unhandled.
-- Note: at the current time, Info, if present is always a copy of
-- the entry point of the procedure, as found by searching the
-- subprogram table. For the case where a procedure is indeed in
-- the table (either it is an Ada procedure, or a foreign procedure
-- which is registered using pragma Propagate_Exceptions), then the
-- entry point information will indeed be correct. It may well be
-- possible for Pop_Frame to avoid using the Info parameter (for
-- example if it consults auxiliary Dwarf tables to do its job).
-- This is desirable if it can be done, because it means that it
-- will work fine to propagate exceptions through unregistered
-- foreign procedures. What will happen is that the search in the
-- Ada subprogram table will find a junk entry. Even if this junk
-- entry has an exception table, none of them will apply to the
-- current location, so they will be ignored, and then Pop_Frame
-- will be called to pop the frame. The Info parameter for this
-- call will be junk, but if it is not used that does not matter.
-- Note that the address recorded in the traceback table is of
-- the exception location, so the traceback will be correct even
-- in this case.
procedure Enter_Handler
(M : Machine_State;
Handler : System.Exceptions.Handler_Loc);
-- When Propagate_Handler locates an applicable exception handler, it
-- calls Enter_Handler, passing it two parameters. The first is the
-- machine state that corresponds to what is required for entry to
-- the handler, as computed by repeated Pop_Frame calls to reach the
-- handler to be entered. The second is the code location for the
-- handler itself which is the address of the label at the start of
-- the handler code.
--
-- Note: The machine state M is likely stored on the part of the
-- stack that will be popped by the call, so care must be taken
-- not to pop the stack until the Machine_State is entirely read.
-- The value passed as Handler was obtained from elaboration of
-- an N_Handler_Loc node by the backend.
function Fetch_Code (Loc : Code_Loc) return Code_Loc;
-- Some architectures (notably VMS) use a descriptor to describe
@ -150,14 +95,4 @@ package System.Machine_State_Operations is
-- This routine sets M from the current machine state. It is called
-- when an exception is initially signalled to initialize the state.
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address);
-- This routine sets M from the machine state that corresponds to the
-- point in the code where a signal was raised. The parameter Context
-- is a pointer to a structure created by the operating system when a
-- signal is raised, and made available to the signal handler. The
-- format of this context block, and the manner in which it is made
-- available to the handler, are implementation dependent.
end System.Machine_State_Operations;

9
gcc/ada/s-traceb-mastop.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2005 Ada Core Technologies, 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- --
@ -31,8 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This version assumes that System.Machine_State_Operations.Pop_Frame can
-- work with the Info parameter being null.
-- This version uses System.Machine_State_Operations routines
with System.Machine_State_Operations;
@ -73,7 +72,7 @@ package body System.Traceback is
Code := Get_Code_Loc (M);
exit when Code = Null_Address or else N_Skips = Skip_Frames;
Pop_Frame (M, System.Null_Address);
Pop_Frame (M);
N_Skips := N_Skips + 1;
end loop;
@ -90,7 +89,7 @@ package body System.Traceback is
Trace (Len) := Code;
end if;
Pop_Frame (M, System.Null_Address);
Pop_Frame (M);
end loop;
Free_Machine_State (M);

8
gcc/ada/switch-b.adb
View File

@ -126,14 +126,6 @@ package body Switch.B is
end if;
end loop;
-- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
-- is for backwards compatibility with old versions and usage.
if Debug_Flag_XX then
Zero_Cost_Exceptions_Set := True;
Zero_Cost_Exceptions_Val := True;
end if;
return;
-- Processing for D switch

8
gcc/ada/switch-m.adb
View File

@ -585,14 +585,6 @@ package body Switch.M is
end if;
end loop;
-- Make sure Zero_Cost_Exceptions is set if gnatdX set. This
-- is for backwards compatibility with old versions and usage.
if Debug_Flag_XX then
Zero_Cost_Exceptions_Set := True;
Zero_Cost_Exceptions_Val := True;
end if;
return;
-- Processing for e switch

10
gcc/ada/targparm.adb
View File

@ -67,10 +67,9 @@ package body Targparm is
UAM, -- Use_Ada_Main_Program_Name
VMS, -- OpenVMS
ZCD, -- ZCX_By_Default
ZCG, -- GCC_ZCX_Support
ZCF); -- Front_End_ZCX_Support
ZCG); -- GCC_ZCX_Support
subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCF;
subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCG;
-- Range excluding obsolete entries
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
@ -106,7 +105,6 @@ package body Targparm is
VMS_Str : aliased constant Source_Buffer := "OpenVMS";
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
-- The following defines a set of pointers to the above strings,
-- indexed by the tag values.
@ -140,8 +138,7 @@ package body Targparm is
UAM_Str'Access,
VMS_Str'Access,
ZCD_Str'Access,
ZCG_Str'Access,
ZCF_Str'Access);
ZCG_Str'Access);
-----------------------
-- Local Subprograms --
@ -571,7 +568,6 @@ package body Targparm is
when VMS => OpenVMS_On_Target := Result;
when ZCD => ZCX_By_Default_On_Target := Result;
when ZCG => GCC_ZCX_Support_On_Target := Result;
when ZCF => Front_End_ZCX_Support_On_Target := Result;
goto Line_Loop_Continue;
end case;

45
gcc/ada/targparm.ads
View File

@ -278,50 +278,24 @@ package Targparm is
-- Controlling the selection of methods
-- The Front-End Longjmp/Setjmp approach is always available in
-- all implementations. If it is not the default method, then it
-- may be explicitly specified by the use of -gnatL. Note however
-- that there is a requirement that all Ada units in a partition
-- be compiled with this overriding option if it is not the default.
-- On some, but not all, implementations of GNAT, one of the two
-- ZCX approaches (but not both) is implemented. If this is the
-- case, and ZCX is not the default mechanism, then ZCX handling
-- (front-end or back-end according to the implementation) may be
-- specified by use of the -gnatZ switch. Again, this switch must
-- be used to compile all Ada units in a partition. The use of
-- the -gnatZ switch will cause termination with a fatal error.
-- Finally the debug option -gnatdX can be used to force the
-- compiler to operate in front-end ZCX exception mode and force
-- the front end to generate exception tables. This is only useful
-- for debugging purposes for implementations which do not provide
-- the possibility of front-end ZCX mode. The resulting object file
-- is unusable, but this debug switch may still be useful (e.g. in
-- conjunction with -gnatG) for front-end debugging purposes.
-- On most implementations, back-end zero-cost exceptions are used.
-- Otherwise, Front-End Longjmp/Setjmp approach is used.
-- Note that there is a requirement that all Ada units in a partition
-- be compiled with the same exception model.
-- Control of Available Methods and Defaults
-- The following switches specify which of the two ZCX methods
-- (if any) is available in an implementation, and which method
-- is the default method.
-- The following switches specify whether ZCX is available, and
-- whether it is enabled by default.
ZCX_By_Default_On_Target : Boolean := False;
-- Indicates if zero cost exceptions are active by default. If this
-- variable is False, then the only possible exception method is the
-- front-end setjmp/longjmp approach, and this is the default. If
-- this variable is True, then one of the following two flags must
-- be True, and represents the method to be used by default.
-- this variable is True, then GCC ZCX is used.
GCC_ZCX_Support_On_Target : Boolean := False;
-- Indicates that when ZCX is active, the mechanism to be used is the
-- back-end ZCX exception approach. If this variable is set to True,
-- then Front_End_ZCX_Support_On_Target must be False.
Front_End_ZCX_Support_On_Target : Boolean := False;
-- Indicates that when ZCX is active, the mechanism to be used is the
-- front-end ZCX exception approach. If this variable is set to True,
-- then GCC_ZCX_Support_On_Target must be False.
-- Indicates that the target supports GCC Exceptions.
------------------------------------
-- Run-Time Library Configuration --
@ -367,9 +341,6 @@ package Targparm is
-- with the exception of the priority of the environment task, which
-- is needed by the Ravenscar run-time.
--
-- The generation of exception tables is suppressed for front end
-- ZCX exception handling (since we assume no exception handling).
--
-- The calls to __gnat_initialize and __gnat_finalize are omitted
--
-- All finalization and initialization (controlled types) is omitted

10
gcc/ada/usage.adb
View File

@ -220,11 +220,6 @@ begin
Write_Switch_Char ("l");
Write_Line ("Output full source listing with embedded error messages");
-- Line for -gnatL switch
Write_Switch_Char ("L");
Write_Line ("Use longjmp/setjmp for exception handling");
-- Line for -gnatm switch
Write_Switch_Char ("mnnn");
@ -465,11 +460,6 @@ begin
Write_Switch_Char ("z");
Write_Line ("Distribution stub generation (r/c for receiver/caller stubs)");
-- Line for -gnatZ switch
Write_Switch_Char ("Z");
Write_Line ("Use zero cost exception handling");
-- Line for -gnat83 switch
Write_Switch_Char ("83");