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 \
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 \
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
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 \
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 \
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
s-crc32$(objext) \
s-direio$(objext) \
s-errrep$(objext) \
- s-except$(objext) \
s-exctab$(objext) \
s-exnint$(objext) \
s-exnllf$(objext) \
Exclude_Min => Code_Address_For_AAA,
Exclude_Max => Code_Address_For_ZZZ,
Skip_Frames => 3);
-
end if;
end Call_Chain;
-- 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
-- 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
--
-- 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.
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
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;
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
-- 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
-- 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
-- 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
-- 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");
-- 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");
-- 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 --
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
-- 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
-- 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
----------------------------
procedure Raise_Constraint_Error
- (File : Big_String_Ptr;
+ (File : System.Address;
Line : Integer)
is
begin
--------------------------------
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
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);
-------------------------
procedure Raise_Program_Error
- (File : Big_String_Ptr;
+ (File : System.Address;
Line : Integer)
is
begin
-----------------------------
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
-------------------------
procedure Raise_Storage_Error
- (File : Big_String_Ptr;
+ (File : System.Address;
Line : Integer)
is
begin
-----------------------------
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
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);
-- 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;
-------------
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;
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;
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;
-
-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;
+ return Start_Of_ZZZ'Address;
+ end Code_Address_For_ZZZ;
- pragma Warnings (On);
end Ada.Exceptions;
-- 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;
------------------
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
-- 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);
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);
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 --
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
-- 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;
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,
Tracebacks => (others => TBE.Null_TB_Entry),
Private_Data => System.Null_Address);
- pragma Warnings (On);
-
end Ada.Exceptions;
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;
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;
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
-- 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;
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)
-- 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.
-- 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
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
-- 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.
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 --
------------------
-- internal file appears.
procedure Write_Linker_Option;
- -- Write binder info linker option.
+ -- Write binder info linker option
-------------------------
-- Write_Linker_Option --
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 --
-------------
-- 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
-- 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.
with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
with Hostparm; use Hostparm;
-with Inline; use Inline;
-with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
-with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-with Uname; use Uname;
package body Exp_Ch11 is
- SD_List : List_Id;
- -- This list gathers the values SDn'Unrestricted_Access used to
- -- construct the unit exception table. It is set to Empty_List if
- -- there are no subprogram descriptors.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Expand_Exception_Handler_Tables (HSS : Node_Id);
- -- Subsidiary procedure called by Expand_Exception_Handlers if zero
- -- cost exception handling is installed for this target. Replaces the
- -- exception handler structure with appropriate labeled code and tables
- -- that allow the zero cost exception handling circuits to find the
- -- correct handler (see unit Ada.Exceptions for details).
-
- procedure Generate_Subprogram_Descriptor
- (N : Node_Id;
- Loc : Source_Ptr;
- Spec : Entity_Id;
- Slist : List_Id);
- -- Procedure called to generate a subprogram descriptor. N is the
- -- subprogram body node or, in the case of an imported subprogram, is
- -- Empty, and Spec is the entity of the sunprogram. For details of the
- -- required structure, see package System.Exceptions. The generated
- -- subprogram descriptor is appended to Slist. Loc provides the
- -- source location to be used for the generated descriptor.
-
---------------------------
-- Expand_At_End_Handler --
---------------------------
-- Don't expand if back end exception handling active
- if Exception_Mechanism = Back_End_ZCX_Exceptions then
+ if Exception_Mechanism = Back_End_Exceptions then
return;
end if;
end if;
end Expand_At_End_Handler;
- -------------------------------------
- -- Expand_Exception_Handler_Tables --
- -------------------------------------
-
- -- See Ada.Exceptions specification for full details of the data
- -- structures that we need to construct here. As an example of the
- -- transformation that is required, given the structure:
-
- -- declare
- -- {declarations}
- -- ..
- -- begin
- -- {statements-1}
- -- ...
- -- exception
- -- when a | b =>
- -- {statements-2}
- -- ...
- -- when others =>
- -- {statements-3}
- -- ...
- -- end;
-
- -- We transform this into:
-
- -- declare
- -- {declarations}
- -- ...
- -- L1 : label;
- -- L2 : label;
- -- L3 : label;
- -- L4 : Label;
- -- L5 : label;
-
- -- begin
- -- <<L1>>
- -- {statements-1}
- -- <<L2>>
-
- -- exception
-
- -- when a | b =>
- -- <<L3>>
- -- {statements-2}
-
- -- HR2 : constant Handler_Record := (
- -- Lo => L1'Address,
- -- Hi => L2'Address,
- -- Id => a'Identity,
- -- Handler => L5'Address);
-
- -- HR3 : constant Handler_Record := (
- -- Lo => L1'Address,
- -- Hi => L2'Address,
- -- Id => b'Identity,
- -- Handler => L4'Address);
-
- -- when others =>
- -- <<L4>>
- -- {statements-3}
-
- -- HR1 : constant Handler_Record := (
- -- Lo => L1'Address,
- -- Hi => L2'Address,
- -- Id => Others_Id,
- -- Handler => L4'Address);
- -- end;
-
- -- The exception handlers in the transformed version are marked with the
- -- Zero_Cost_Handling flag set, and all gigi does in this case is simply
- -- to put the handler code somewhere. It can optionally be put inline
- -- between the goto L3 and the label <<L3>> (which is why we generate
- -- that goto in the first place).
-
- procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is
- Loc : constant Source_Ptr := Sloc (HSS);
- Handlrs : constant List_Id := Exception_Handlers (HSS);
- Stms : constant List_Id := Statements (HSS);
- Handler : Node_Id;
-
- Hlist : List_Id;
- -- This is the list to which handlers are to be appended. It is
- -- either the list for the enclosing subprogram, or the enclosing
- -- selective accept statement (which will turn into a subprogram
- -- during expansion later on).
-
- L1 : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- L2 : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- Lnn : Entity_Id;
- Choice : Node_Id;
- E_Id : Node_Id;
- HR_Ent : Node_Id;
- HL_Ref : Node_Id;
- Item : Node_Id;
-
- Subp_Entity : Entity_Id;
- -- This is the entity for the subprogram (or library level package)
- -- to which the handler record is to be attached for later reference
- -- in a subprogram descriptor for this entity.
-
- procedure Append_To_Stms (N : Node_Id);
- -- Append given statement to the end of the statements of the
- -- handled sequence of statements and analyze it in place.
-
- function Inside_Selective_Accept return Boolean;
- -- This function is called if we are inside the scope of an entry
- -- or task. It checks if the handler is appearing in the context
- -- of a selective accept statement. If so, Hlist is set to
- -- temporarily park the handlers in the N_Accept_Alternative.
- -- node. They will subsequently be moved to the procedure entity
- -- for the procedure built for this alternative. The statements that
- -- follow the Accept within the alternative are not inside the Accept
- -- for purposes of this test, and handlers that may appear within
- -- them belong in the enclosing task procedure.
-
- procedure Set_Hlist;
- -- Sets the handler list corresponding to Subp_Entity
-
- --------------------
- -- Append_To_Stms --
- --------------------
-
- procedure Append_To_Stms (N : Node_Id) is
- begin
- Insert_After_And_Analyze (Last (Stms), N);
- Set_Exception_Junk (N);
- end Append_To_Stms;
-
- -----------------------------
- -- Inside_Selective_Accept --
- -----------------------------
-
- function Inside_Selective_Accept return Boolean is
- Parnt : Node_Id;
- Curr : Node_Id := HSS;
-
- begin
- Parnt := Parent (HSS);
- while Nkind (Parnt) /= N_Compilation_Unit loop
- if Nkind (Parnt) = N_Accept_Alternative
- and then Curr = Accept_Statement (Parnt)
- then
- if Present (Accept_Handler_Records (Parnt)) then
- Hlist := Accept_Handler_Records (Parnt);
- else
- Hlist := New_List;
- Set_Accept_Handler_Records (Parnt, Hlist);
- end if;
-
- return True;
- else
- Curr := Parnt;
- Parnt := Parent (Parnt);
- end if;
- end loop;
-
- return False;
- end Inside_Selective_Accept;
-
- ---------------
- -- Set_Hlist --
- ---------------
-
- procedure Set_Hlist is
- begin
- -- Never try to inline a subprogram with exception handlers
-
- Set_Is_Inlined (Subp_Entity, False);
-
- if Present (Subp_Entity)
- and then Present (Handler_Records (Subp_Entity))
- then
- Hlist := Handler_Records (Subp_Entity);
- else
- Hlist := New_List;
- Set_Handler_Records (Subp_Entity, Hlist);
- end if;
- end Set_Hlist;
-
- -- Start of processing for Expand_Exception_Handler_Tables
-
- begin
- -- Nothing to do if this handler has already been processed
-
- if Zero_Cost_Handling (HSS) then
- return;
- end if;
-
- Set_Zero_Cost_Handling (HSS);
-
- -- Find the parent subprogram or package scope containing this
- -- exception frame. This should always find a real package or
- -- subprogram. If it does not it will stop at Standard, but
- -- this cannot legitimately occur.
-
- -- We only stop at library level packages, for inner packages
- -- we always attach handlers to the containing procedure.
-
- Subp_Entity := Current_Scope;
- Scope_Loop : loop
-
- -- Never need tables expanded inside a generic template
-
- if Is_Generic_Unit (Subp_Entity) then
- return;
-
- -- Stop if we reached containing subprogram. Go to protected
- -- subprogram if there is one defined.
-
- elsif Ekind (Subp_Entity) = E_Function
- or else Ekind (Subp_Entity) = E_Procedure
- then
- if Present (Protected_Body_Subprogram (Subp_Entity)) then
- Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
- end if;
-
- Set_Hlist;
- exit Scope_Loop;
-
- -- Case of within an entry
-
- elsif Is_Entry (Subp_Entity) then
-
- -- Protected entry, use corresponding body subprogram
-
- if Present (Protected_Body_Subprogram (Subp_Entity)) then
- Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
- Set_Hlist;
- exit Scope_Loop;
-
- -- Check if we are within a selective accept alternative
-
- elsif Inside_Selective_Accept then
-
- -- As a side effect, Inside_Selective_Accept set Hlist,
- -- in much the same manner as Set_Hlist, except that
- -- the list involved was the one for the selective accept.
-
- exit Scope_Loop;
- end if;
-
- -- Case of within library level package
-
- elsif Ekind (Subp_Entity) = E_Package
- and then Is_Compilation_Unit (Subp_Entity)
- then
- if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
- Subp_Entity := Body_Entity (Subp_Entity);
- end if;
-
- Set_Hlist;
- exit Scope_Loop;
-
- -- Task type case
-
- elsif Ekind (Subp_Entity) = E_Task_Type then
-
- -- Check if we are within a selective accept alternative
-
- if Inside_Selective_Accept then
-
- -- As a side effect, Inside_Selective_Accept set Hlist,
- -- in much the same manner as Set_Hlist, except that the
- -- list involved was the one for the selective accept.
-
- exit Scope_Loop;
-
- -- Stop if we reached task type with task body procedure,
- -- use the task body procedure.
-
- elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
- Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
- Set_Hlist;
- exit Scope_Loop;
- end if;
- end if;
-
- -- If we fall through, keep looking
-
- Subp_Entity := Scope (Subp_Entity);
- end loop Scope_Loop;
-
- pragma Assert (Subp_Entity /= Standard_Standard);
-
- -- Analyze standard labels
-
- Analyze_Label_Entity (L1);
- Analyze_Label_Entity (L2);
-
- Insert_Before_And_Analyze (First (Stms),
- Make_Label (Loc,
- Identifier => New_Occurrence_Of (L1, Loc)));
- Set_Exception_Junk (First (Stms));
-
- Append_To_Stms (
- Make_Label (Loc,
- Identifier => New_Occurrence_Of (L2, Loc)));
-
- -- Loop through exception handlers
-
- Handler := First_Non_Pragma (Handlrs);
- while Present (Handler) loop
- Set_Zero_Cost_Handling (Handler);
-
- -- Add label at start of handler, and goto at the end
-
- Lnn :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- Analyze_Label_Entity (Lnn);
-
- Item :=
- Make_Label (Loc,
- Identifier => New_Occurrence_Of (Lnn, Loc));
- Set_Exception_Junk (Item);
- Insert_Before_And_Analyze (First (Statements (Handler)), Item);
-
- -- Loop through choices
-
- Choice := First (Exception_Choices (Handler));
- while Present (Choice) loop
-
- -- Others (or all others) choice
-
- if Nkind (Choice) = N_Others_Choice then
- if All_Others (Choice) then
- E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc);
- else
- E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
- end if;
-
- -- Special case of VMS_Exception. Not clear what we will do
- -- eventually here if and when we implement zero cost exceptions
- -- on VMS. But at least for now, don't blow up trying to take
- -- a garbage code address for such an exception.
-
- elsif Is_VMS_Exception (Entity (Choice)) then
- E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
-
- -- Normal case of specific exception choice
-
- else
- E_Id :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Entity (Choice), Loc),
- Attribute_Name => Name_Identity);
- end if;
-
- HR_Ent :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('H'));
-
- HL_Ref :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (HR_Ent, Loc),
- Attribute_Name => Name_Unrestricted_Access);
-
- -- Now we need to add the entry for the new handler record to
- -- the list of handler records for the current subprogram.
-
- -- Normally we end up generating the handler records in exactly
- -- the right order. Here right order means innermost first,
- -- since the table will be searched sequentially. Since we
- -- generally expand from outside to inside, the order is just
- -- what we want, and we need to append the new entry to the
- -- end of the list.
-
- -- However, there are exceptions, notably in the case where
- -- a generic body is inserted later on. See for example the
- -- case of ACVC test C37213J, which has the following form:
-
- -- generic package x ... end x;
- -- package body x is
- -- begin
- -- ...
- -- exception (1)
- -- ...
- -- end x;
-
- -- ...
-
- -- declare
- -- package q is new x;
- -- begin
- -- ...
- -- exception (2)
- -- ...
- -- end;
-
- -- In this case, we will expand exception handler (2) first,
- -- since the expansion of (1) is delayed till later when the
- -- generic body is inserted. But (1) belongs before (2) in
- -- the chain.
-
- -- Note that scopes are not totally ordered, because two
- -- scopes can be in parallel blocks, so that it does not
- -- matter what order these entries appear in. An ordering
- -- relation exists if one scope is inside another, and what
- -- we really want is some partial ordering.
-
- -- A simple, not very efficient, but adequate algorithm to
- -- achieve this partial ordering is to search the list for
- -- the first entry containing the given scope, and put the
- -- new entry just before it.
-
- declare
- New_Scop : constant Entity_Id := Current_Scope;
- Ent : Node_Id;
-
- begin
- Ent := First (Hlist);
- loop
- -- If all searched, then we can just put the new
- -- entry at the end of the list (it actually does
- -- not matter where we put it in this case).
-
- if No (Ent) then
- Append_To (Hlist, HL_Ref);
- exit;
-
- -- If the current scope is within the scope of the
- -- entry then insert the entry before to retain the
- -- proper order as per above discussion.
-
- -- Note that for equal entries, we just keep going,
- -- which is fine, the entry will end up at the end
- -- of the list where it belongs.
-
- elsif Scope_Within
- (New_Scop, Scope (Entity (Prefix (Ent))))
- then
- Insert_Before (Ent, HL_Ref);
- exit;
-
- -- Otherwise keep looking
-
- else
- Next (Ent);
- end if;
- end loop;
- end;
-
- Item :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => HR_Ent,
- Constant_Present => True,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
-
- Expression =>
- Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Attribute_Reference (Loc, -- Lo
- Prefix => New_Occurrence_Of (L1, Loc),
- Attribute_Name => Name_Address),
-
- Make_Attribute_Reference (Loc, -- Hi
- Prefix => New_Occurrence_Of (L2, Loc),
- Attribute_Name => Name_Address),
-
- E_Id, -- Id
-
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler
- Attribute_Name => Name_Address))));
-
- Set_Handler_List_Entry (Item, HL_Ref);
- Set_Exception_Junk (Item);
- Insert_After_And_Analyze (Last (Statements (Handler)), Item);
- Set_Is_Statically_Allocated (HR_Ent);
-
- -- If this is a late insertion (from body instance) it is being
- -- inserted in the component list of an already analyzed aggre-
- -- gate, and must be analyzed explicitly.
-
- Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
-
- Next (Choice);
- end loop;
-
- Next_Non_Pragma (Handler);
- end loop;
- end Expand_Exception_Handler_Tables;
-
-------------------------------
-- Expand_Exception_Handlers --
-------------------------------
then
Set_Exception_Handlers (HSS, No_List);
end if;
-
- -- The last step for expanding exception handlers is to expand the
- -- exception tables if zero cost exception handling is active.
-
- if Exception_Mechanism = Front_End_ZCX_Exceptions then
- Expand_Exception_Handler_Tables (HSS);
- end if;
end Expand_Exception_Handlers;
------------------------------------
Analyze_And_Resolve (N, RTE (RE_Code_Loc));
end Expand_N_Subprogram_Info;
- ------------------------------------
- -- Generate_Subprogram_Descriptor --
- ------------------------------------
-
- procedure Generate_Subprogram_Descriptor
- (N : Node_Id;
- Loc : Source_Ptr;
- Spec : Entity_Id;
- Slist : List_Id)
- is
- Code : Node_Id;
- Ent : Entity_Id;
- Decl : Node_Id;
- Dtyp : Entity_Id;
- Numh : Nat;
- Sdes : Node_Id;
- Hrc : List_Id;
-
- begin
- if Exception_Mechanism /= Front_End_ZCX_Exceptions then
- return;
- end if;
-
- if Restriction_Active (No_Exception_Handlers) then
- return;
- end if;
-
- -- Suppress descriptor if we are not generating code. This happens
- -- in the case of a -gnatc -gnatt compilation where we force generics
- -- to be generated, but we still don't want exception tables.
-
- if Operating_Mode /= Generate_Code then
- return;
- end if;
-
- -- Suppress descriptor if we are in No_Exceptions restrictions mode,
- -- since we can never propagate exceptions in any case in this mode.
- -- The same consideration applies for No_Exception_Handlers (which
- -- is also set in High_Integrity_Mode).
-
- if Restriction_Active (No_Exceptions)
- or Restriction_Active (No_Exception_Handlers)
- then
- return;
- end if;
-
- -- Suppress descriptor if we are inside a generic. There are two
- -- ways that we can tell that, depending on what is going on. If
- -- we are actually inside the processing for a generic right now,
- -- then Expander_Active will be reset. If we are outside the
- -- generic, then we will see the generic entity.
-
- if not Expander_Active then
- return;
- end if;
-
- -- Suppress descriptor is subprogram is marked as eliminated, for
- -- example if this is a subprogram created to analyze a default
- -- expression with potential side effects. Ditto if it is nested
- -- within an eliminated subprogram, for example a cleanup action.
-
- declare
- Scop : Entity_Id;
-
- begin
- Scop := Spec;
- while Scop /= Standard_Standard loop
- if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
- return;
- end if;
-
- Scop := Scope (Scop);
- end loop;
- end;
-
- -- Suppress descriptor for original protected subprogram (we will
- -- be called again later to generate the descriptor for the actual
- -- protected body subprogram.) This does not apply to barrier
- -- functions which are there own protected subprogram.
-
- if Is_Subprogram (Spec)
- and then Present (Protected_Body_Subprogram (Spec))
- and then Protected_Body_Subprogram (Spec) /= Spec
- then
- return;
- end if;
-
- -- Suppress descriptors for packages unless they have at least one
- -- handler. The binder will generate the dummy (no handler) descriptors
- -- for elaboration procedures. We can't do it here, because we don't
- -- know if an elaboration routine does in fact exist.
-
- -- If there is at least one handler for the package spec or body
- -- then most certainly an elaboration routine must exist, so we
- -- can safely reference it.
-
- if (Nkind (N) = N_Package_Declaration
- or else
- Nkind (N) = N_Package_Body)
- and then No (Handler_Records (Spec))
- then
- return;
- end if;
-
- -- Suppress all subprogram descriptors for the file System.Exceptions.
- -- We similarly suppress subprogram descriptors for Ada.Exceptions.
- -- These are all init procs for types which cannot raise exceptions.
- -- The reason this is done is that otherwise we get embarassing
- -- elaboration dependencies.
-
- Get_Name_String (Unit_File_Name (Current_Sem_Unit));
-
- if Name_Buffer (1 .. 12) = "s-except.ads"
- or else
- Name_Buffer (1 .. 12) = "a-except.ads"
- then
- return;
- end if;
-
- -- Similarly, we need to suppress entries for System.Standard_Library,
- -- since otherwise we get elaboration circularities. Again, this would
- -- better be done with a Suppress_Initialization pragma :-)
-
- if Name_Buffer (1 .. 11) = "s-stalib.ad" then
- return;
- end if;
-
- -- For now, also suppress entries for s-stoele because we have
- -- some kind of unexplained error there ???
-
- if Name_Buffer (1 .. 11) = "s-stoele.ad" then
- return;
- end if;
-
- -- And also for g-htable, because it cannot raise exceptions,
- -- and generates some kind of elaboration order problem.
-
- if Name_Buffer (1 .. 11) = "g-htable.ad" then
- return;
- end if;
-
- -- Suppress subprogram descriptor if already generated. This happens
- -- in the case of late generation from Delay_Subprogram_Descriptors
- -- beging set (where there is more than one instantiation in the list)
-
- if Has_Subprogram_Descriptor (Spec) then
- return;
- else
- Set_Has_Subprogram_Descriptor (Spec);
- end if;
-
- -- Never generate descriptors for inlined bodies
-
- if Analyzing_Inlined_Bodies then
- return;
- end if;
-
- -- Here we definitely are going to generate a subprogram descriptor
-
- declare
- Hnum : Nat := Homonym_Number (Spec);
-
- begin
- if Hnum = 1 then
- Hnum := 0;
- end if;
-
- Ent :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Spec), "SD", Hnum));
- end;
-
- if No (Handler_Records (Spec)) then
- Hrc := Empty_List;
- Numh := 0;
- else
- Hrc := Handler_Records (Spec);
- Numh := List_Length (Hrc);
- end if;
-
- New_Scope (Spec);
-
- -- We need a static subtype for the declaration of the subprogram
- -- descriptor. For the case of 0-3 handlers we can use one of the
- -- predefined subtypes in System.Exceptions. For more handlers,
- -- we build our own subtype here.
-
- case Numh is
- when 0 =>
- Dtyp := RTE (RE_Subprogram_Descriptor_0);
-
- when 1 =>
- Dtyp := RTE (RE_Subprogram_Descriptor_1);
-
- when 2 =>
- Dtyp := RTE (RE_Subprogram_Descriptor_2);
-
- when 3 =>
- Dtyp := RTE (RE_Subprogram_Descriptor_3);
-
- when others =>
- Dtyp :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
-
- -- Set the constructed type as global, since we will be
- -- referencing the object that is of this type globally
-
- Set_Is_Statically_Allocated (Dtyp);
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Dtyp,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc, Numh)))));
-
- Append (Decl, Slist);
-
- -- We analyze the descriptor for the subprogram and package
- -- case, but not for the imported subprogram case (it will
- -- be analyzed when the freeze entity actions are analyzed.
-
- if Present (N) then
- Analyze (Decl);
- end if;
-
- Set_Exception_Junk (Decl);
- end case;
-
- -- Prepare the code address entry for the table entry. For the normal
- -- case of being within a procedure, this is simply:
-
- -- P'Code_Address
-
- -- where P is the procedure, but for the package case, it is
-
- -- P'Elab_Body'Code_Address
- -- P'Elab_Spec'Code_Address
-
- -- for the body and spec respectively. Note that we do our own
- -- analysis of these attribute references, because we know in this
- -- case that the prefix of ELab_Body/Spec is a visible package,
- -- which can be referenced directly instead of using the general
- -- case expansion for these attributes.
-
- if Ekind (Spec) = E_Package then
- Code :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Spec, Loc),
- Attribute_Name => Name_Elab_Spec);
- Set_Etype (Code, Standard_Void_Type);
- Set_Analyzed (Code);
-
- elsif Ekind (Spec) = E_Package_Body then
- Code :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc),
- Attribute_Name => Name_Elab_Body);
- Set_Etype (Code, Standard_Void_Type);
- Set_Analyzed (Code);
-
- else
- Code := New_Occurrence_Of (Spec, Loc);
- end if;
-
- Code :=
- Make_Attribute_Reference (Loc,
- Prefix => Code,
- Attribute_Name => Name_Code_Address);
-
- Set_Etype (Code, RTE (RE_Address));
- Set_Analyzed (Code);
-
- -- Now we can build the subprogram descriptor
-
- Sdes :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Constant_Present => True,
- Aliased_Present => True,
- Object_Definition => New_Occurrence_Of (Dtyp, Loc),
-
- Expression =>
- Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Numh), -- Num_Handlers
-
- Code, -- Code
-
--- temp code ???
-
--- Make_Subprogram_Info (Loc, -- Subprogram_Info
--- Identifier =>
--- New_Occurrence_Of (Spec, Loc)),
-
- New_Copy_Tree (Code),
-
- Make_Aggregate (Loc, -- Handler_Records
- Expressions => Hrc))));
-
- Set_Exception_Junk (Sdes);
- Set_Is_Subprogram_Descriptor (Sdes);
-
- Append (Sdes, Slist);
-
- -- We analyze the descriptor for the subprogram and package case,
- -- but not for the imported subprogram case (it will be analyzed
- -- when the freeze entity actions are analyzed.
-
- if Present (N) then
- Analyze (Sdes);
- end if;
-
- -- We can now pop the scope used for analyzing the descriptor
-
- Pop_Scope;
-
- -- We need to set the descriptor as statically allocated, since
- -- it will be referenced from the unit exception table.
-
- Set_Is_Statically_Allocated (Ent);
-
- -- Append the resulting descriptor to the list. We do this only
- -- if we are in the main unit. You might think that we could
- -- simply skip generating the descriptors completely if we are
- -- not in the main unit, but in fact this is not the case, since
- -- we have problems with inconsistent serial numbers for internal
- -- names if we do this.
-
- if In_Extended_Main_Code_Unit (Spec) then
- Append_To (SD_List,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent, Loc),
- Attribute_Name => Name_Unrestricted_Access));
-
- Unit_Exception_Table_Present := True;
- end if;
-
- end Generate_Subprogram_Descriptor;
-
- ------------------------------------------------------------
- -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
- ------------------------------------------------------------
-
- procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
- (Spec : Entity_Id;
- Slist : List_Id)
- is
- begin
- Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
- end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
-
- ------------------------------------------------
- -- Generate_Subprogram_Descriptor_For_Package --
- ------------------------------------------------
-
- procedure Generate_Subprogram_Descriptor_For_Package
- (N : Node_Id;
- Spec : Entity_Id)
- is
- Adecl : Node_Id;
-
- begin
- -- If N is empty with prior errors, ignore
-
- if Total_Errors_Detected /= 0 and then No (N) then
- return;
- end if;
-
- -- Do not generate if no exceptions
-
- if Restriction_Active (No_Exception_Handlers) then
- return;
- end if;
-
- -- Otherwise generate descriptor
-
- Adecl := Aux_Decls_Node (Parent (N));
-
- if No (Actions (Adecl)) then
- Set_Actions (Adecl, New_List);
- end if;
-
- Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
- end Generate_Subprogram_Descriptor_For_Package;
-
- ---------------------------------------------------
- -- Generate_Subprogram_Descriptor_For_Subprogram --
- ---------------------------------------------------
-
- procedure Generate_Subprogram_Descriptor_For_Subprogram
- (N : Node_Id;
- Spec : Entity_Id)
- is
- begin
- -- If we have no subprogram body and prior errors, ignore
-
- if Total_Errors_Detected /= 0 and then No (N) then
- return;
- end if;
-
- -- Do not generate if no exceptions
-
- if Restriction_Active (No_Exception_Handlers) then
- return;
- end if;
-
- -- Else generate descriptor
-
- declare
- HSS : constant Node_Id := Handled_Statement_Sequence (N);
-
- begin
- if No (Exception_Handlers (HSS)) then
- Generate_Subprogram_Descriptor
- (N, Sloc (N), Spec, Statements (HSS));
- else
- Generate_Subprogram_Descriptor
- (N, Sloc (N),
- Spec, Statements (Last (Exception_Handlers (HSS))));
- end if;
- end;
- end Generate_Subprogram_Descriptor_For_Subprogram;
-
- -----------------------------------
- -- Generate_Unit_Exception_Table --
- -----------------------------------
-
- -- The only remaining thing to generate here is to generate the
- -- reference to the subprogram descriptor chain. See Ada.Exceptions
- -- for details of required data structures.
-
- procedure Generate_Unit_Exception_Table is
- Loc : constant Source_Ptr := No_Location;
- Num : Nat;
- Decl : Node_Id;
- Ent : Entity_Id;
- Next_Ent : Entity_Id;
- Stent : Entity_Id;
-
- begin
- -- Nothing to be done if zero length exceptions not active
-
- if Exception_Mechanism /= Front_End_ZCX_Exceptions then
- return;
- end if;
-
- -- Nothing to do if no exceptions
-
- if Restriction_Active (No_Exception_Handlers) then
- return;
- end if;
-
- -- Remove any entries from SD_List that correspond to eliminated
- -- subprograms.
-
- Ent := First (SD_List);
- while Present (Ent) loop
- Next_Ent := Next (Ent);
- if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
- Remove (Ent); -- After this, there is no Next (Ent) anymore
- end if;
-
- Ent := Next_Ent;
- end loop;
-
- -- Nothing to do if no unit exception table present.
- -- An empty table can result from subprogram elimination,
- -- in such a case, eliminate the exception table itself.
-
- if Is_Empty_List (SD_List) then
- Unit_Exception_Table_Present := False;
- return;
- end if;
-
- -- Do not generate table in a generic
-
- if Inside_A_Generic then
- return;
- end if;
-
- -- Generate the unit exception table
-
- -- subtype Tnn is Subprogram_Descriptors_Record (Num);
- -- __gnat_unitname__SDP : aliased constant Tnn :=
- -- Num,
- -- (sub1'unrestricted_access,
- -- sub2'unrestricted_access,
- -- ...
- -- subNum'unrestricted_access));
-
- Num := List_Length (SD_List);
-
- Stent :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
-
- Insert_Library_Level_Action (
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Stent,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Subprogram_Descriptors_Record), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc, Num))))));
-
- Set_Is_Statically_Allocated (Stent);
-
- Get_External_Unit_Name_String (Unit_Name (Main_Unit));
- Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
- Name_Buffer (1 .. 7) := "__gnat_";
- Name_Len := Name_Len + 7;
- Add_Str_To_Name_Buffer ("__SDP");
-
- Ent :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Find);
-
- Get_Name_String (Chars (Ent));
- Set_Interface_Name (Ent,
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Object_Definition => New_Occurrence_Of (Stent, Loc),
- Constant_Present => True,
- Aliased_Present => True,
- Expression =>
- Make_Aggregate (Loc,
- New_List (
- Make_Integer_Literal (Loc, List_Length (SD_List)),
-
- Make_Aggregate (Loc,
- Expressions => SD_List))));
-
- Insert_Library_Level_Action (Decl);
-
- Set_Is_Exported (Ent, True);
- Set_Is_Public (Ent, True);
- Set_Is_Statically_Allocated (Ent, True);
-
- Get_Name_String (Chars (Ent));
- Set_Interface_Name (Ent,
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
-
- end Generate_Unit_Exception_Table;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- SD_List := Empty_List;
- end Initialize;
-
----------------------
-- Is_Non_Ada_Error --
----------------------
return True;
end Is_Non_Ada_Error;
- ----------------------------
- -- Remove_Handler_Entries --
- ----------------------------
-
- procedure Remove_Handler_Entries (N : Node_Id) is
- function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
- -- This function checks one node for a possible reference to a
- -- handler entry that must be deleted. it always returns OK.
-
- function Remove_All_Handler_Entries is new
- Traverse_Func (Check_Handler_Entry);
- -- This defines the traversal operation
-
- Discard : Traverse_Result;
- pragma Warnings (Off, Discard);
-
- function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) = N_Object_Declaration then
-
- if Present (Handler_List_Entry (N)) then
- Remove (Handler_List_Entry (N));
- Delete_Tree (Handler_List_Entry (N));
- Set_Handler_List_Entry (N, Empty);
-
- elsif Is_Subprogram_Descriptor (N) then
- declare
- SDN : Node_Id;
-
- begin
- SDN := First (SD_List);
- while Present (SDN) loop
- if Defining_Identifier (N) = Entity (Prefix (SDN)) then
- Remove (SDN);
- Delete_Tree (SDN);
- exit;
- end if;
-
- Next (SDN);
- end loop;
- end;
- end if;
- end if;
-
- return OK;
- end Check_Handler_Entry;
-
- -- Start of processing for Remove_Handler_Entries
-
- begin
- if Exception_Mechanism = Front_End_ZCX_Exceptions then
- Discard := Remove_All_Handler_Entries (N);
- end if;
- end Remove_Handler_Entries;
-
end Exp_Ch11;
-- --
-- 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- --
-- 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
-- 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;
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;
if Result = No_List then
Result := Empty_List;
end if;
-
- Generate_Subprogram_Descriptor_For_Imported_Subprogram
- (E, Result);
end if;
end if;
-- --
-- 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- --
with CStand;
with Debug; use Debug;
with Elists;
-with Exp_Ch11;
with Exp_Dbug;
with Fmap;
with Fname.UF;
Lib.Load.Initialize;
Sem_Ch8.Initialize;
Fname.UF.Initialize;
- Exp_Ch11.Initialize;
Checks.Initialize;
-- Create package Standard
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
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");
-- --
-- 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- --
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;
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;
-- --
-- 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- --
-- 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
-- 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.
-- -- 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>>
--
-- --
-- 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- --
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;
Linker_Option_Lines.Init;
Load_Stack.Init;
Units.Init;
- Unit_Exception_Table_Present := False;
Compilation_Switches.Init;
end Initialize;
****************************************************************************/
+/* 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
package body System.Machine_State_Operations is
use System.Storage_Elements;
- use System.Exceptions;
-- The exc_unwind function in libexc operats on a Sigcontext
(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 --
----------------
-- 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);
-- 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;
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
(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 --
----------------
-- 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");
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;
package body System.Machine_State_Operations is
- use System.Exceptions;
subtype Cond_Value_Type is Unsigned_Longword;
-- Record layouts copied from Starlet.
(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 --
----------------
-- 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);
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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- 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- --
pragma Warnings (Off);
- use System.Exceptions;
-
----------------------------
-- Allocate_Machine_State --
----------------------------
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 --
----------------
-- 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;
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;
-- --
-- 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- --
-- elaboration circularities with System.Exception_Tables.
with System.Storage_Elements;
-with System.Exceptions;
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
-- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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;
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;
Trace (Len) := Code;
end if;
- Pop_Frame (M, System.Null_Address);
+ Pop_Frame (M);
end loop;
Free_Machine_State (M);
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
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
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);
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.
UAM_Str'Access,
VMS_Str'Access,
ZCD_Str'Access,
- ZCG_Str'Access,
- ZCF_Str'Access);
+ ZCG_Str'Access);
-----------------------
-- Local Subprograms --
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;
-- 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 --
-- 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
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");
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");
projects / platform / upstream / linaro-gcc.git / commitdiff