From 3a7fc3d614abf9a85891594846f87e16c858f635 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 5 Sep 2005 07:46:59 +0000 Subject: [PATCH] PR ada/23646 * s-mastop-tru64.adb, s-mastop-irix.adb, s-mastop-vms.adb (Enter_Handler, Set_Signal_Machine_State): Removed, no longer used. Remove reference to System.Exceptions. * s-mastop-x86.adb: Removed, no longer used. * s-traceb-mastop.adb: Adjust calls to Pop_Frame. * a-excach.adb: Minor reformatting. * a-except.ads, a-except.adb: Remove global Warnings (Off) pragma, and instead fix new warnings that were hidden by this change. (AAA, ZZZ): Removed, replaced by... (Code_Address_For_AAA, Code_Address_For_ZZZ): ... these functions, who are used instead of constants, to help make Ada.Exception truly preelaborate. (Rcheck_*, Raise_Constraint_Error, Raise_Program_Error, Raise_Storage_Error): File is now a System.Address, to simplify code. (Elab code): Removed, no longer used. (Null_Occurrence): Remove Warnings Off and make this construct preelaborate. Remove code related to front-end zero cost exception handling, since it is no longer used. Remove -gnatL/-gnatZ switches. * a-exexda.adb (Append_Info_Exception_Name, Set_Exception_C_Msg): Update use of Except.Msg. * gnat1drv.adb, inline.adb, bindgen.adb, debug.adb, exp_ch11.ads, freeze.adb, frontend.adb, lib.adb, exp_ch11.adb: Remove code related to front-end zero cost exception handling, since it is no longer used. Remove -gnatL/-gnatZ switches. * lib-writ.ads: Minor reformatting Remove doc of UX * Makefile.rtl: Remove references to s-except*, s-mastop-x86* * Make-lang.in: Remove references to s-except.ads * s-except.ads: Removed, no longer used. * s-mastop.ads, s-mastop.adb: (Enter_Handler, Set_Signal_Machine_State): Removed, no longer used. Remove reference to System.Exceptions. * raise.h, usage.adb, targparm.adb, targparm.ads, switch-m.adb, switch-b.adb: Remove code related to front-end zero cost exception handling, since it is no longer used. Remove -gnatL/-gnatZ switches. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103848 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/Make-lang.in | 12 +- gcc/ada/Makefile.rtl | 1 - gcc/ada/a-excach.adb | 1 - gcc/ada/a-except.adb | 363 +++++++------- gcc/ada/a-except.ads | 77 ++- gcc/ada/a-exexda.adb | 16 +- gcc/ada/bindgen.adb | 362 +------------- gcc/ada/debug.adb | 9 +- gcc/ada/exp_ch11.adb | 1156 +------------------------------------------ gcc/ada/exp_ch11.ads | 55 +- gcc/ada/freeze.adb | 4 - gcc/ada/frontend.adb | 9 +- gcc/ada/gnat1drv.adb | 22 +- gcc/ada/inline.adb | 26 +- gcc/ada/lib-writ.ads | 10 +- gcc/ada/lib.adb | 4 +- gcc/ada/raise.h | 8 +- gcc/ada/s-except.ads | 203 -------- gcc/ada/s-mastop-irix.adb | 84 +--- gcc/ada/s-mastop-tru64.adb | 37 +- gcc/ada/s-mastop-vms.adb | 64 +-- gcc/ada/s-mastop-x86.adb | 594 ---------------------- gcc/ada/s-mastop.adb | 29 +- gcc/ada/s-mastop.ads | 69 +-- gcc/ada/s-traceb-mastop.adb | 9 +- gcc/ada/switch-b.adb | 8 - gcc/ada/switch-m.adb | 8 - gcc/ada/targparm.adb | 10 +- gcc/ada/targparm.ads | 45 +- gcc/ada/usage.adb | 10 - 30 files changed, 255 insertions(+), 3050 deletions(-) delete mode 100644 gcc/ada/s-except.ads delete mode 100644 gcc/ada/s-mastop-x86.adb diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index c9d1c26..8b47630 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -113,7 +113,7 @@ GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \ GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \ ada/a-elchha.o ada/a-ioexce.o \ ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \ - ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/s-except.o ada/ali.o \ + ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/ali.o \ ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \ ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \ ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \ @@ -215,7 +215,6 @@ GNATBIND_OBJS = \ ada/s-casuti.o \ ada/s-crc32.o \ ada/s-crtl.o \ - ada/s-except.o \ ada/s-exctab.o \ ada/s-htable.o \ ada/s-imgenu.o \ @@ -1101,7 +1100,7 @@ ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \ ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \ ada/a-elchha.ads ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads \ ada/a-uncdea.ads ada/interfac.ads ada/system.ads ada/s-exctab.ads \ - ada/s-except.ads ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ ada/s-traceb.ads ada/s-traent.ads ada/s-traent.adb ada/s-unstyp.ads \ ada/unchconv.ads @@ -2606,9 +2605,6 @@ ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \ ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads -ada/s-except.o : ada/ada.ads ada/a-except.ads ada/system.ads \ - ada/s-except.ads ada/s-stalib.ads ada/s-traent.ads ada/unchconv.ads - ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ ada/s-htable.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ @@ -2621,7 +2617,7 @@ ada/s-imgenu.o : ada/system.ads ada/s-imgenu.ads ada/s-imgenu.adb \ ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads ada/s-mastop.o : ada/ada.ads ada/a-except.ads ada/system.ads \ - ada/s-except.ads ada/s-mastop.ads ada/s-mastop.adb ada/s-stalib.ads \ + ada/s-mastop.ads ada/s-mastop.adb ada/s-stalib.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/system.ads \ @@ -2639,7 +2635,7 @@ ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/system.ads \ ada/s-traent.ads ada/unchconv.ads ada/unchdeal.ads ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/system.ads \ - ada/s-except.ads ada/s-mastop.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-mastop.ads ada/s-parame.ads ada/s-secsta.ads \ ada/s-soflin.ads ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/unchconv.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 76b2eb1..aa92689 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -375,7 +375,6 @@ GNATRTL_NONTASKING_OBJS= \ s-crc32$(objext) \ s-direio$(objext) \ s-errrep$(objext) \ - s-except$(objext) \ s-exctab$(objext) \ s-exnint$(objext) \ s-exnllf$(objext) \ diff --git a/gcc/ada/a-excach.adb b/gcc/ada/a-excach.adb index 7bb0141..f411315 100644 --- a/gcc/ada/a-excach.adb +++ b/gcc/ada/a-excach.adb @@ -71,7 +71,6 @@ begin Exclude_Min => Code_Address_For_AAA, Exclude_Max => Code_Address_For_ZZZ, Skip_Frames => 3); - end if; end Call_Chain; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 0949b57..a676b91 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -35,14 +35,9 @@ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. -pragma Warnings (Off); --- Since several constructs give warnings in 3.14a1, including unreferenced --- variables and pragma Unreferenced itself. - with System; use System; with System.Standard_Library; use System.Standard_Library; with System.Soft_Links; use System.Soft_Links; -with System.Machine_State_Operations; use System.Machine_State_Operations; package body Ada.Exceptions is @@ -71,11 +66,11 @@ package body Ada.Exceptions is -- from C clients using the given external name, even though they are not -- technically visible in the Ada sense. - procedure AAA; - procedure ZZZ; - -- Mark start and end of procedures in this package + function Code_Address_For_AAA return System.Address; + function Code_Address_For_ZZZ return System.Address; + -- Return start and end of procedures in this package -- - -- The AAA and ZZZ procedures are used to provide exclusion bounds in + -- These procedures are used to provide exclusion bounds in -- calls to Call_Chain at exception raise points from this unit. The -- purpose is to arrange for the exception tracebacks not to include -- frames from routines involved in the raise process, as these are @@ -83,27 +78,18 @@ package body Ada.Exceptions is -- -- For these bounds to be meaningful, we need to ensure that the object -- code for the routines involved in processing a raise is located after - -- the object code for AAA and before the object code for ZZZ. This will - -- indeed be the case as long as the following rules are respected: + -- the object code Code_Address_For_AAA and before the object code + -- Code_Address_For_ZZZ. This will indeed be the case as long as the + -- following rules are respected: -- -- 1) The bodies of the subprograms involved in processing a raise - -- are located after the body of AAA and before the body of ZZZ. + -- are located after the body of Code_Address_For_AAA and before the + -- body of Code_Address_For_ZZZ. -- -- 2) No pragma Inline applies to any of these subprograms, as this -- could delay the corresponding assembly output until the end of -- the unit. - Code_Address_For_AAA, Code_Address_For_ZZZ : System.Address; - -- Used to represent addresses really inside the code range for AAA and - -- ZZZ, initialized to the address of a label inside the corresponding - -- procedure. This is initialization takes place inside the procedures - -- themselves, which are called as part of the elaboration code. - -- - -- We are doing this instead of merely using Proc'Address because on some - -- platforms the latter does not yield the address we want, but the - -- address of a stub or of a descriptor instead. This is the case at least - -- on Alpha-VMS and PA-HPUX. - procedure Call_Chain (Excep : EOA); -- Store up to Max_Tracebacks in Excep, corresponding to the current -- call chain. @@ -139,9 +125,9 @@ package body Ada.Exceptions is procedure Set_Exception_C_Msg (Id : Exception_Id; - Msg1 : Big_String_Ptr; + Msg1 : System.Address; Line : Integer := 0; - Msg2 : Big_String_Ptr := null); + Msg2 : System.Address := System.Null_Address); -- This routine is called to setup the exception referenced by the -- Current_Excep field in the TSD to contain the indicated Id value -- and message. Msg1 is a null terminated string which is generated @@ -210,7 +196,7 @@ package body Ada.Exceptions is pragma Export (Ada, Tailored_Exception_Information, "__gnat_tailored_exception_information"); - -- This is currently used by System.Tasking.Stages. + -- This is currently used by System.Tasking.Stages end Exception_Data; @@ -329,9 +315,9 @@ package body Ada.Exceptions is procedure Raise_With_Location_And_Msg (E : Exception_Id; - F : Big_String_Ptr; + F : System.Address; L : Integer; - M : Big_String_Ptr := null); + M : System.Address := System.Null_Address); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception @@ -339,7 +325,7 @@ package body Ada.Exceptions is -- this (if M is not null). procedure Raise_Constraint_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer); pragma No_Return (Raise_Constraint_Error); pragma Export @@ -347,16 +333,16 @@ package body Ada.Exceptions is -- Raise constraint error with file:line information procedure Raise_Constraint_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr); + Msg : System.Address); pragma No_Return (Raise_Constraint_Error_Msg); pragma Export (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); -- Raise constraint error with file:line + msg information procedure Raise_Program_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer); pragma No_Return (Raise_Program_Error); pragma Export @@ -364,16 +350,16 @@ package body Ada.Exceptions is -- Raise program error with file:line information procedure Raise_Program_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr); + Msg : System.Address); pragma No_Return (Raise_Program_Error_Msg); pragma Export (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); -- Raise program error with file:line + msg information procedure Raise_Storage_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer); pragma No_Return (Raise_Storage_Error); pragma Export @@ -381,9 +367,9 @@ package body Ada.Exceptions is -- Raise storage error with file:line information procedure Raise_Storage_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr); + Msg : System.Address); pragma No_Return (Raise_Storage_Error_Msg); pragma Export (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); @@ -454,37 +440,37 @@ package body Ada.Exceptions is -- to the codes defined in Types.ads and a-types.h (for example, -- the name Rcheck_05 refers to the Reason whose Pos code is 5). - procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer); - procedure Rcheck_30 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_00 (File : System.Address; Line : Integer); + procedure Rcheck_01 (File : System.Address; Line : Integer); + procedure Rcheck_02 (File : System.Address; Line : Integer); + procedure Rcheck_03 (File : System.Address; Line : Integer); + procedure Rcheck_04 (File : System.Address; Line : Integer); + procedure Rcheck_05 (File : System.Address; Line : Integer); + procedure Rcheck_06 (File : System.Address; Line : Integer); + procedure Rcheck_07 (File : System.Address; Line : Integer); + procedure Rcheck_08 (File : System.Address; Line : Integer); + procedure Rcheck_09 (File : System.Address; Line : Integer); + procedure Rcheck_10 (File : System.Address; Line : Integer); + procedure Rcheck_11 (File : System.Address; Line : Integer); + procedure Rcheck_12 (File : System.Address; Line : Integer); + procedure Rcheck_13 (File : System.Address; Line : Integer); + procedure Rcheck_14 (File : System.Address; Line : Integer); + procedure Rcheck_15 (File : System.Address; Line : Integer); + procedure Rcheck_16 (File : System.Address; Line : Integer); + procedure Rcheck_17 (File : System.Address; Line : Integer); + procedure Rcheck_18 (File : System.Address; Line : Integer); + procedure Rcheck_19 (File : System.Address; Line : Integer); + procedure Rcheck_20 (File : System.Address; Line : Integer); + procedure Rcheck_21 (File : System.Address; Line : Integer); + procedure Rcheck_22 (File : System.Address; Line : Integer); + procedure Rcheck_23 (File : System.Address; Line : Integer); + procedure Rcheck_24 (File : System.Address; Line : Integer); + procedure Rcheck_25 (File : System.Address; Line : Integer); + procedure Rcheck_26 (File : System.Address; Line : Integer); + procedure Rcheck_27 (File : System.Address; Line : Integer); + procedure Rcheck_28 (File : System.Address; Line : Integer); + procedure Rcheck_29 (File : System.Address; Line : Integer); + procedure Rcheck_30 (File : System.Address; Line : Integer); pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); @@ -611,19 +597,25 @@ package body Ada.Exceptions is -- The actual polling routine is separate, so that it can easily -- be replaced with a target dependent version. - --------- - -- AAA -- - --------- + -------------------------- + -- Code_Address_For_AAA -- + -------------------------- - -- This dummy procedure gives us the start of the PC range for addresses + -- This function gives us the start of the PC range for addresses -- within the exception unit itself. We hope that gigi/gcc keep all the -- procedures in their original order! - procedure AAA is + function Code_Address_For_AAA return System.Address is begin + -- We are using a label instead of merely using + -- Code_Address_For_AAA'Address because on some platforms the latter + -- does not yield the address we want, but the address of a stub or of + -- a descriptor instead. This is the case at least on Alpha-VMS and + -- PA-HPUX. + <> - Code_Address_For_AAA := Start_Of_AAA'Address; - end AAA; + return Start_Of_AAA'Address; + end Code_Address_For_AAA; ---------------- -- Call_Chain -- @@ -714,7 +706,7 @@ package body Ada.Exceptions is raise Constraint_Error; end if; - return Id.Full_Name.all (1 .. Id.Name_Length - 1); + return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); end Exception_Name; function Exception_Name (X : Exception_Occurrence) return String is @@ -793,7 +785,7 @@ package body Ada.Exceptions is -- This is so the debugger can reliably inspect the parameter Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Excep : EOA := Get_Current_Excep.all; + Excep : constant EOA := Get_Current_Excep.all; begin -- WARNING : There should be no exception handler for this body @@ -803,43 +795,44 @@ package body Ada.Exceptions is -- we are handling, which would completely break the whole design -- of this procedure. - -- Processing varies between zero cost and setjmp/lonjmp processing. + -- Processing varies between zero cost and setjmp/lonjmp processing if Zero_Cost_Exceptions /= 0 then - -- Use the front-end tables to propagate if we have them, otherwise - -- resort to the GCC back-end alternative. Backtrace computation is - -- performed, if required, by the underlying routine. Notifications - -- for the debugger are also not performed here, because we do not - -- yet know if the exception is handled. + -- Use the GCC back-end to propagate the exception. Backtrace + -- computation is performed, if required, by the underlying routine. + -- Notifications for the debugger are also not performed here, + -- because we do not yet know if the exception is handled. Exception_Propagation.Propagate_Exception (From_Signal_Handler); else - -- Compute the backtrace for this occurrence if the corresponding - -- binder option has been set. Call_Chain takes care of the reraise - -- case. + -- Compute the backtrace for this occurrence if corresponding binder + -- option has been set. Call_Chain takes care of the reraise case. Call_Chain (Excep); + + -- Note on above call to Call_Chain: + -- We used to only do this if From_Signal_Handler was not set, -- based on the assumption that backtracing from a signal handler -- would not work due to stack layout oddities. However, since - -- + -- 1. The flag is never set in tasking programs (Notify_Exception -- performs regular raise statements), and - -- + -- 2. No problem has shown up in tasking programs around here so -- far, this turned out to be too strong an assumption. - -- + -- As, in addition, the test was - -- + -- 1. preventing the production of backtraces in non-tasking -- programs, and - -- + -- 2. introducing a behavior inconsistency between -- the tasking and non-tasking cases, - -- - -- we have simply removed it. + + -- we have simply removed it -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this @@ -872,7 +865,7 @@ package body Ada.Exceptions is ---------------------------- procedure Raise_Constraint_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer) is begin @@ -885,9 +878,9 @@ package body Ada.Exceptions is -------------------------------- procedure Raise_Constraint_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr) + Msg : System.Address) is begin Raise_With_Location_And_Msg @@ -941,7 +934,7 @@ package body Ada.Exceptions is procedure Raise_From_Signal_Handler (E : Exception_Id; - M : Big_String_Ptr) + M : System.Address) is begin Exception_Data.Set_Exception_C_Msg (E, M); @@ -954,7 +947,7 @@ package body Ada.Exceptions is ------------------------- procedure Raise_Program_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer) is begin @@ -967,9 +960,9 @@ package body Ada.Exceptions is ----------------------------- procedure Raise_Program_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr) + Msg : System.Address) is begin Raise_With_Location_And_Msg @@ -981,7 +974,7 @@ package body Ada.Exceptions is ------------------------- procedure Raise_Storage_Error - (File : Big_String_Ptr; + (File : System.Address; Line : Integer) is begin @@ -994,9 +987,9 @@ package body Ada.Exceptions is ----------------------------- procedure Raise_Storage_Error_Msg - (File : Big_String_Ptr; + (File : System.Address; Line : Integer; - Msg : Big_String_Ptr) + Msg : System.Address) is begin Raise_With_Location_And_Msg @@ -1009,9 +1002,9 @@ package body Ada.Exceptions is procedure Raise_With_Location_And_Msg (E : Exception_Id; - F : Big_String_Ptr; + F : System.Address; L : Integer; - M : Big_String_Ptr := null) + M : System.Address := System.Null_Address) is begin Exception_Data.Set_Exception_C_Msg (E, F, L, M); @@ -1042,159 +1035,159 @@ package body Ada.Exceptions is -- Calls to Run-Time Check Routines -- -------------------------------------- - procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_00 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address); end Rcheck_00; - procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_01 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address); end Rcheck_01; - procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_02 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address); end Rcheck_02; - procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_03 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address); end Rcheck_03; - procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_04 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address); end Rcheck_04; - procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_05 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address); end Rcheck_05; - procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_06 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address); end Rcheck_06; - procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_07 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address); end Rcheck_07; - procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_08 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address); end Rcheck_08; - procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_09 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address); end Rcheck_09; - procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_10 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address); end Rcheck_10; - procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_11 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address); end Rcheck_11; - procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_12 (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); + Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address); end Rcheck_12; - procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_13 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_13'Address); end Rcheck_13; - procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_14 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); end Rcheck_14; - procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_15 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); end Rcheck_15; - procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_16 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); end Rcheck_16; - procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_17 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); end Rcheck_17; - procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_18 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); end Rcheck_18; - procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_19 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); end Rcheck_19; - procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_20 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); end Rcheck_20; - procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_21 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); end Rcheck_21; - procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_22 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); end Rcheck_22; - procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_23 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_23'Address); end Rcheck_23; - procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_24 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); end Rcheck_24; - procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_25 (File : System.Address; Line : Integer) is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); + Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); end Rcheck_25; - procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_26 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); + Raise_Storage_Error_Msg (File, Line, Rmsg_26'Address); end Rcheck_26; - procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_27 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); + Raise_Storage_Error_Msg (File, Line, Rmsg_27'Address); end Rcheck_27; - procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_28 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); + Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address); end Rcheck_28; - procedure Rcheck_29 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_29 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_29'Address)); + Raise_Storage_Error_Msg (File, Line, Rmsg_29'Address); end Rcheck_29; - procedure Rcheck_30 (File : Big_String_Ptr; Line : Integer) is + procedure Rcheck_30 (File : System.Address; Line : Integer) is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_30'Address)); + Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address); end Rcheck_30; ------------- @@ -1263,7 +1256,7 @@ package body Ada.Exceptions is end Save_Occurrence; function Save_Occurrence (Source : Exception_Occurrence) return EOA is - Target : EOA := new Exception_Occurrence; + Target : constant EOA := new Exception_Occurrence; begin Save_Occurrence (Target.all, Source); return Target; @@ -1348,8 +1341,7 @@ package body Ada.Exceptions is begin Exception_Data.Set_Exception_Msg (E, Message); - -- DO NOT CALL Abort_Defer.all; !!!! - -- why not??? would be nice to have more comments here + -- Do not call Abort_Defer.all, as specified by the spec Raise_Current_Excep (E); end Raise_Exception_No_Defer; @@ -1378,35 +1370,18 @@ package body Ada.Exceptions is end loop; end To_Stderr; - --------- - -- ZZZ -- - --------- + -------------------------- + -- Code_Address_For_ZZZ -- + -------------------------- - -- This dummy procedure gives us the end of the PC range for addresses + -- This function gives us the end of the PC range for addresses -- within the exception unit itself. We hope that gigi/gcc keeps all the -- procedures in their original order! - procedure ZZZ is + function Code_Address_For_ZZZ return System.Address is begin <> - 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; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 73a6a29..a93f056 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -39,24 +39,18 @@ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with ourself. -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules! - with System; with System.Parameters; with System.Standard_Library; with System.Traceback_Entries; -pragma Warnings (On); package Ada.Exceptions is -pragma Warnings (Off); -pragma Preelaborate_05 (Exceptions); -pragma Warnings (On); --- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we can --- compile this using older compiler versions, which will ignore the pragma, --- which is fine for the bootstrap. + pragma Warnings (Off); + pragma Preelaborate_05; + pragma Warnings (On); + -- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we + -- can compile this using older compiler versions, which will ignore the + -- pragma, which is fine for the bootstrap. type Exception_Id is private; Null_Id : constant Exception_Id; @@ -127,10 +121,9 @@ private ------------------ subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call - -- addresses when propagating an exception. - -- Values of this type are created by using Label'Address or - -- extracted from machine states using Get_Code_Loc. + -- Code location used in building exception tables and for call addresses + -- when propagating an exception. Values of this type are created by using + -- Label'Address or extracted from machine states using Get_Code_Loc. Null_Loc : constant Code_Loc := System.Null_Address; -- Null code location, used to flag outer level frame @@ -161,12 +154,12 @@ private -- to be in the visible part, since this is set by the reference manual). function Exception_Name_Simple (X : Exception_Occurrence) return String; - -- Like Exception_Name, but returns the simple non-qualified name of - -- the exception. This is used to implement the Exception_Name function - -- in Current_Exceptions (the DEC compatible unit). It is called from - -- the compiler generated code (using Rtsfind, which does not respect - -- the private barrier, so we can place this function in the private - -- part where the compiler can find it, but the spec is unchanged.) + -- Like Exception_Name, but returns the simple non-qualified name of the + -- exception. This is used to implement the Exception_Name function in + -- Current_Exceptions (the DEC compatible unit). It is called from the + -- compiler generated code (using Rtsfind, which does not respect the + -- private barrier, so we can place this function in the private part + -- where the compiler can find it, but the spec is unchanged.) procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); pragma No_Return (Raise_Exception_Always); @@ -179,22 +172,21 @@ private procedure Raise_From_Signal_Handler (E : Exception_Id; - M : SSL.Big_String_Ptr); + M : System.Address); pragma Export (Ada, Raise_From_Signal_Handler, "ada__exceptions__raise_from_signal_handler"); pragma No_Return (Raise_From_Signal_Handler); - -- This routine is used to raise an exception from a signal handler. - -- The signal handler has already stored the machine state (i.e. the - -- state that corresponds to the location at which the signal was - -- raised). E is the Exception_Id specifying what exception is being - -- raised, and M is a pointer to a null-terminated string which is the - -- message to be raised. Note that this routine never returns, so it is - -- permissible to simply jump to this routine, rather than call it. This - -- may be appropriate for systems where the right way to get out of a - -- signal handler is to alter the PC value in the machine state or in - -- some other way ask the operating system to return here rather than - -- to the original location. + -- This routine is used to raise an exception from a signal handler. The + -- signal handler has already stored the machine state (i.e. the state that + -- corresponds to the location at which the signal was raised). E is the + -- Exception_Id specifying what exception is being raised, and M is a + -- pointer to a null-terminated string which is the message to be raised. + -- Note that this routine never returns, so it is permissible to simply + -- jump to this routine, rather than call it. This may be appropriate for + -- systems where the right way to get out of signal handler is to alter the + -- PC value in the machine state or in some other way ask the operating + -- system to return here rather than to the original location. procedure Reraise_Occurrence_Always (X : Exception_Occurrence); pragma No_Return (Reraise_Occurrence_Always); @@ -207,8 +199,8 @@ private pragma No_Return (Reraise_Occurrence_No_Defer); -- Exactly like Reraise_Occurrence, except that abort is not deferred -- before the call and the parameter X is known not to be the null - -- occurrence. This is used in generated code when it is known - -- that abort is already deferred. + -- occurrence. This is used in generated code when it is known that + -- abort is already deferred. ----------------------- -- Polling Interface -- @@ -260,7 +252,7 @@ private Msg : String (1 .. Exception_Msg_Max_Length); -- Characters of message - Cleanup_Flag : Boolean; + Cleanup_Flag : Boolean := False; -- The cleanup flag is normally False, it is set True for an exception -- occurrence passed to a cleanup routine, and will still be set True -- when the cleanup routine does a Reraise_Occurrence call using this @@ -276,7 +268,7 @@ private -- it is dealing with the reraise case (which is useful to distinguish -- for exception tracing purposes). - Pid : Natural; + Pid : Natural := 0; -- Partition_Id for partition raising exception Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; @@ -302,13 +294,8 @@ private pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); -- Functions for implementing Exception_Occurrence stream attributes - pragma Warnings (Off); - -- Allow non-static constants in Ada 2005 mode where this package will be - -- implicitly categorized as Preelaborate. See AI-362 for details. It is - -- safe in the context of the run-time to violate the rules! - Null_Occurrence : constant Exception_Occurrence := ( - Id => Null_Id, + Id => null, Msg_Length => 0, Msg => (others => ' '), Cleanup_Flag => False, @@ -318,6 +305,4 @@ private Tracebacks => (others => TBE.Null_TB_Entry), Private_Data => System.Null_Address); - pragma Warnings (On); - end Ada.Exceptions; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 901b386..6049ccd 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -476,7 +476,7 @@ package body Exception_Data is declare Len : constant Natural := Exception_Name_Length (Id); - Name : constant String (1 .. Len) := Id.Full_Name (1 .. Len); + Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); begin Append_Info_String (Name, Info, Ptr); end; @@ -556,9 +556,9 @@ package body Exception_Data is procedure Set_Exception_C_Msg (Id : Exception_Id; - Msg1 : Big_String_Ptr; + Msg1 : System.Address; Line : Integer := 0; - Msg2 : Big_String_Ptr := null) + Msg2 : System.Address := System.Null_Address) is Excep : constant EOA := Get_Current_Excep.all; Val : Integer := Line; @@ -575,11 +575,11 @@ package body Exception_Data is Excep.Msg_Length := 0; Excep.Cleanup_Flag := False; - while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL + while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length loop Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); + Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length); end loop; -- Append line number if present @@ -613,18 +613,18 @@ package body Exception_Data is -- Append second message if present - if Msg2 /= null + if Msg2 /= System.Null_Address and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length then Excep.Msg_Length := Excep.Msg_Length + 1; Excep.Msg (Excep.Msg_Length) := ' '; Ptr := 1; - while Msg2 (Ptr) /= ASCII.NUL + while To_Ptr (Msg2) (Ptr) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length loop Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); + Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr); Ptr := Ptr + 1; end loop; end if; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index bd38674..bdb864f 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -201,16 +201,6 @@ package body Bindgen is procedure Gen_Elab_Defs_C; -- Generate sequence of definitions for elaboration routines (C code case) - procedure Gen_Exception_Table_Ada; - -- Generate binder exception table (Ada code case). This consists of - -- declarations followed by a begin followed by a call. If zero cost - -- exceptions are not active, then only the begin is generated. - - procedure Gen_Exception_Table_C; - -- Generate binder exception table (C code case). This has no effect - -- if zero cost exceptions are not active, otherwise it generates a - -- set of declarations followed by a call. - procedure Gen_Main_Ada; -- Generate procedure main (Ada code case) @@ -279,9 +269,6 @@ package body Bindgen is -- Set given character in Statement_Buffer at the Last + 1 position -- and increment Last by one to reflect the stored character. - procedure Set_EA_Last; - -- Output the number of elements in array EA - procedure Set_Int (N : Int); -- Set given value in decimal in Statement_Buffer with no spaces -- starting at the Last + 1 position, and updating Last past the value. @@ -296,7 +283,7 @@ package body Bindgen is -- is generated starting at Last + 1, and Last is updated past it. procedure Set_Name_Buffer; - -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer. + -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer procedure Set_String (S : String); -- Sets characters of given string in Statement_Buffer, starting at the @@ -550,10 +537,7 @@ package body Bindgen is WBI (" Handler_Installed : Integer;"); WBI (" pragma Import (C, Handler_Installed, " & """__gnat_handler_installed"");"); - - -- Generate exception table - - Gen_Exception_Table_Ada; + WBI (" begin"); -- Generate the call to Set_Globals @@ -782,10 +766,8 @@ package body Bindgen is -- Code for normal case (standard library not suppressed) - Gen_Exception_Table_C; - -- Generate call to set the runtime global variables defined in - -- a-init.c. We define the varables in a-init.c, rather than in + -- init.c. We define the varables in init.c, rather than in -- the binder generated file itself to avoid undefined externals -- when the runtime is linked as a shareable image library. @@ -1228,324 +1210,6 @@ package body Bindgen is WBI (" END ELABORATION ORDER */"); end Gen_Elab_Order_C; - ----------------------------- - -- Gen_Exception_Table_Ada -- - ----------------------------- - - procedure Gen_Exception_Table_Ada is - Num : Nat; - Last : ALI_Id := No_ALI_Id; - - begin - if not Zero_Cost_Exceptions_Specified then - WBI (" begin"); - return; - end if; - - -- The code we generate looks like - - -- procedure SDP_Table_Build - -- (SDP_Addresses : System.Address; - -- SDP_Count : Natural; - -- Elab_Addresses : System.Address; - -- Elab_Addr_Count : Natural); - -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); - -- - -- ST : aliased constant array (1 .. nnn) of System.Address := ( - -- unit_name_1'UET_Address, - -- unit_name_2'UET_Address, - -- ... - -- unit_name_3'UET_Address, - -- - -- EA : aliased constant array (1 .. eee) of System.Address := ( - -- adainit'Code_Address, - -- adafinal'Code_Address, - -- unit_name'elab[spec|body]'Code_Address, - -- unit_name'elab[spec|body]'Code_Address, - -- unit_name'elab[spec|body]'Code_Address, - -- unit_name'elab[spec|body]'Code_Address); - -- - -- begin - -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee); - - Num := 0; - for A in ALIs.First .. ALIs.Last loop - if not ALIs.Table (A).SAL_Interface - and then ALIs.Table (A).Unit_Exception_Table - then - Num := Num + 1; - Last := A; - end if; - end loop; - - if Num = 0 then - - -- Happens with "gnatmake -a -f -gnatL ..." - - WBI (" "); - WBI (" begin"); - return; - end if; - - WBI (" procedure SDP_Table_Build"); - WBI (" (SDP_Addresses : System.Address;"); - WBI (" SDP_Count : Natural;"); - WBI (" Elab_Addresses : System.Address;"); - WBI (" Elab_Addr_Count : Natural);"); - WBI (" " & - "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");"); - - WBI (" "); - Set_String (" ST : aliased constant array (1 .. "); - Set_Int (Num); - Set_String (") of System.Address := ("); - - if Num = 1 then - Set_String ("1 => "); - - else - Write_Statement_Buffer; - end if; - - for A in ALIs.First .. ALIs.Last loop - if not ALIs.Table (A).SAL_Interface - and then ALIs.Table (A).Unit_Exception_Table - then - Get_Decoded_Name_String_With_Brackets - (Units.Table (ALIs.Table (A).First_Unit).Uname); - Set_Casing (Mixed_Case); - - if Num /= 1 then - Set_String (" "); - end if; - - Set_String (Name_Buffer (1 .. Name_Len - 2)); - Set_String ("'UET_Address"); - - if A = Last then - Set_String (");"); - else - Set_Char (','); - end if; - - Write_Statement_Buffer; - end if; - end loop; - - WBI (" "); - Set_String (" EA : aliased constant array (1 .. "); - Set_EA_Last; - Set_String (") of System.Address := ("); - Write_Statement_Buffer; - Set_String (" " & Ada_Init_Name.all & "'Code_Address"); - - -- If compiling for the JVM, we directly reference Adafinal because - -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). - - if not Cumulative_Restrictions.Set (No_Finalization) then - Set_Char (','); - Write_Statement_Buffer; - - if Hostparm.Java_VM then - Set_String - (" System.Standard_Library.Adafinal'Code_Address"); - else - Set_String - (" Do_Finalize'Code_Address"); - end if; - end if; - - for E in Elab_Order.First .. Elab_Order.Last loop - Get_Decoded_Name_String_With_Brackets - (Units.Table (Elab_Order.Table (E)).Uname); - - if Units.Table (Elab_Order.Table (E)).No_Elab then - null; - - else - Set_Char (','); - Write_Statement_Buffer; - Set_String (" "); - - if Name_Buffer (Name_Len) = 's' then - Name_Buffer (Name_Len - 1 .. Name_Len + 21) := - "'elab_spec'code_address"; - else - Name_Buffer (Name_Len - 1 .. Name_Len + 21) := - "'elab_body'code_address"; - end if; - - Name_Len := Name_Len + 21; - Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing); - Set_Name_Buffer; - end if; - end loop; - - Set_String (");"); - Write_Statement_Buffer; - - WBI (" "); - WBI (" begin"); - - Set_String (" SDP_Table_Build (ST'Address, "); - Set_Int (Num); - Set_String (", EA'Address, "); - Set_EA_Last; - Set_String (");"); - Write_Statement_Buffer; - end Gen_Exception_Table_Ada; - - --------------------------- - -- Gen_Exception_Table_C -- - --------------------------- - - procedure Gen_Exception_Table_C is - Num : Nat; - Num2 : Nat; - - begin - if not Zero_Cost_Exceptions_Specified then - return; - end if; - - -- The code we generate looks like - - -- extern void *__gnat_unitname1__SDP; - -- extern void *__gnat_unitname2__SDP; - -- ... - -- - -- void **st[nnn] = { - -- &__gnat_unitname1__SDP, - -- &__gnat_unitname2__SDP, - -- ... - -- &__gnat_unitnamen__SDP}; - -- - -- extern void unitname1__elabb (); - -- extern void unitname2__elabb (); - -- ... - -- - -- void (*ea[eee]) () = { - -- adainit, - -- adafinal, - -- unitname1___elab[b,s], - -- unitname2___elab[b,s], - -- ... - -- unitnamen___elab[b,s]}; - -- - -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee); - - Num := 0; - for A in ALIs.First .. ALIs.Last loop - if not ALIs.Table (A).SAL_Interface - and then ALIs.Table (A).Unit_Exception_Table - then - Num := Num + 1; - - Set_String (" extern void *__gnat_"); - Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname); - Set_Unit_Name; - Set_String ("__SDP"); - Set_Char (';'); - Write_Statement_Buffer; - end if; - end loop; - - if Num = 0 then - - -- Happens with "gnatmake -a -f -gnatL ..." - - return; - end if; - - WBI (" "); - - Set_String (" void **st["); - Set_Int (Num); - Set_String ("] = {"); - Write_Statement_Buffer; - - Num2 := 0; - for A in ALIs.First .. ALIs.Last loop - if not ALIs.Table (A).SAL_Interface - and then ALIs.Table (A).Unit_Exception_Table - then - Num2 := Num2 + 1; - - Set_String (" &__gnat_"); - Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname); - Set_Unit_Name; - Set_String ("__SDP"); - - if Num = Num2 then - Set_String ("};"); - else - Set_Char (','); - end if; - - Write_Statement_Buffer; - end if; - end loop; - - WBI (""); - for E in Elab_Order.First .. Elab_Order.Last loop - Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); - - if Units.Table (Elab_Order.Table (E)).No_Elab then - null; - - else - Set_String (" extern void "); - Set_Unit_Name; - Set_String ("___elab"); - Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body - Set_String (" ();"); - Write_Statement_Buffer; - end if; - end loop; - - WBI (""); - Set_String (" void (*ea["); - Set_EA_Last; - Set_String ("]) () = {"); - Write_Statement_Buffer; - - Set_String (" " & Ada_Init_Name.all); - - if not Cumulative_Restrictions.Set (No_Finalization) then - Set_Char (','); - Write_Statement_Buffer; - Set_String (" system__standard_library__adafinal"); - end if; - - for E in Elab_Order.First .. Elab_Order.Last loop - Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); - - if Units.Table (Elab_Order.Table (E)).No_Elab then - null; - - else - Set_Char (','); - Write_Statement_Buffer; - Set_String (" "); - Set_Unit_Name; - Set_String ("___elab"); - Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body - end if; - end loop; - - Set_String ("};"); - Write_Statement_Buffer; - - WBI (" "); - - Set_String (" __gnat_SDP_Table_Build (&st, "); - Set_Int (Num); - Set_String (", ea, "); - Set_EA_Last; - Set_String (");"); - Write_Statement_Buffer; - end Gen_Exception_Table_C; - ------------------ -- Gen_Main_Ada -- ------------------ @@ -1943,7 +1607,7 @@ package body Bindgen is -- internal file appears. procedure Write_Linker_Option; - -- Write binder info linker option. + -- Write binder info linker option ------------------------- -- Write_Linker_Option -- @@ -3132,24 +2796,6 @@ package body Bindgen is Statement_Buffer (Last) := C; end Set_Char; - ----------------- - -- Set_EA_Last -- - ----------------- - - procedure Set_EA_Last is - begin - -- When there is no finalization, only adainit is added - - if Cumulative_Restrictions.Set (No_Finalization) then - Set_Int (Num_Elab_Calls + 1); - - -- When there is finalization, both adainit and adafinal are added - - else - Set_Int (Num_Elab_Calls + 2); - end if; - end Set_EA_Last; - ------------- -- Set_Int -- ------------- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 7bce3fd..2fd5b25 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -89,7 +89,7 @@ package body Debug is -- dU Enable garbage collection of unreachable entities -- dV Enable viewing of all symbols in debugger -- dW Disable warnings on calls for IN OUT parameters - -- dX Enable Frontend ZCX even when it is not supported + -- dX -- dY Enable configurable run-time mode -- dZ Generate listing showing the contents of the dispatch tables @@ -457,13 +457,6 @@ package body Debug is -- task of transitioning incorrect legacy code, we provide this -- undocumented feature for suppressing these warnings. - -- dX Enable frontend ZCX even when it is not supported. Equivalent to - -- -gnatZ but without verifying that System.Front_End_ZCX_Support - -- is set. This causes the front end to generate suitable tables - -- for ZCX handling even when the runtime cannot handle ZCX. This - -- is used for testing the front end for correct ZCX operation, and - -- in particular is useful for multi-target testing. - -- dY Enable configurable run-time mode, just as though the System file -- had Configurable_Run_Time_Mode set to True. This is useful in -- testing high integrity mode. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index d144107..ec6b958 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -32,8 +32,6 @@ with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Util; use Exp_Util; with Hostparm; use Hostparm; -with Inline; use Inline; -with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -42,7 +40,6 @@ with Rtsfind; use Rtsfind; with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; -with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -54,38 +51,9 @@ with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; -with Uname; use Uname; package body Exp_Ch11 is - SD_List : List_Id; - -- This list gathers the values SDn'Unrestricted_Access used to - -- construct the unit exception table. It is set to Empty_List if - -- there are no subprogram descriptors. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Expand_Exception_Handler_Tables (HSS : Node_Id); - -- Subsidiary procedure called by Expand_Exception_Handlers if zero - -- cost exception handling is installed for this target. Replaces the - -- exception handler structure with appropriate labeled code and tables - -- that allow the zero cost exception handling circuits to find the - -- correct handler (see unit Ada.Exceptions for details). - - procedure Generate_Subprogram_Descriptor - (N : Node_Id; - Loc : Source_Ptr; - Spec : Entity_Id; - Slist : List_Id); - -- Procedure called to generate a subprogram descriptor. N is the - -- subprogram body node or, in the case of an imported subprogram, is - -- Empty, and Spec is the entity of the sunprogram. For details of the - -- required structure, see package System.Exceptions. The generated - -- subprogram descriptor is appended to Slist. Loc provides the - -- source location to be used for the generated descriptor. - --------------------------- -- Expand_At_End_Handler -- --------------------------- @@ -130,7 +98,7 @@ package body Exp_Ch11 is -- Don't expand if back end exception handling active - if Exception_Mechanism = Back_End_ZCX_Exceptions then + if Exception_Mechanism = Back_End_Exceptions then return; end if; @@ -172,498 +140,6 @@ package body Exp_Ch11 is end if; end Expand_At_End_Handler; - ------------------------------------- - -- Expand_Exception_Handler_Tables -- - ------------------------------------- - - -- See Ada.Exceptions specification for full details of the data - -- structures that we need to construct here. As an example of the - -- transformation that is required, given the structure: - - -- declare - -- {declarations} - -- .. - -- begin - -- {statements-1} - -- ... - -- exception - -- when a | b => - -- {statements-2} - -- ... - -- when others => - -- {statements-3} - -- ... - -- end; - - -- We transform this into: - - -- declare - -- {declarations} - -- ... - -- L1 : label; - -- L2 : label; - -- L3 : label; - -- L4 : Label; - -- L5 : label; - - -- begin - -- <> - -- {statements-1} - -- <> - - -- exception - - -- when a | b => - -- <> - -- {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 => - -- <> - -- {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 <> (which is why we generate - -- that goto in the first place). - - procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is - Loc : constant Source_Ptr := Sloc (HSS); - Handlrs : constant List_Id := Exception_Handlers (HSS); - Stms : constant List_Id := Statements (HSS); - Handler : Node_Id; - - Hlist : List_Id; - -- This is the list to which handlers are to be appended. It is - -- either the list for the enclosing subprogram, or the enclosing - -- selective accept statement (which will turn into a subprogram - -- during expansion later on). - - L1 : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - L2 : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Lnn : Entity_Id; - Choice : Node_Id; - E_Id : Node_Id; - HR_Ent : Node_Id; - HL_Ref : Node_Id; - Item : Node_Id; - - Subp_Entity : Entity_Id; - -- This is the entity for the subprogram (or library level package) - -- to which the handler record is to be attached for later reference - -- in a subprogram descriptor for this entity. - - procedure Append_To_Stms (N : Node_Id); - -- Append given statement to the end of the statements of the - -- handled sequence of statements and analyze it in place. - - function Inside_Selective_Accept return Boolean; - -- This function is called if we are inside the scope of an entry - -- or task. It checks if the handler is appearing in the context - -- of a selective accept statement. If so, Hlist is set to - -- temporarily park the handlers in the N_Accept_Alternative. - -- node. They will subsequently be moved to the procedure entity - -- for the procedure built for this alternative. The statements that - -- follow the Accept within the alternative are not inside the Accept - -- for purposes of this test, and handlers that may appear within - -- them belong in the enclosing task procedure. - - procedure Set_Hlist; - -- Sets the handler list corresponding to Subp_Entity - - -------------------- - -- Append_To_Stms -- - -------------------- - - procedure Append_To_Stms (N : Node_Id) is - begin - Insert_After_And_Analyze (Last (Stms), N); - Set_Exception_Junk (N); - end Append_To_Stms; - - ----------------------------- - -- Inside_Selective_Accept -- - ----------------------------- - - function Inside_Selective_Accept return Boolean is - Parnt : Node_Id; - Curr : Node_Id := HSS; - - begin - Parnt := Parent (HSS); - while Nkind (Parnt) /= N_Compilation_Unit loop - if Nkind (Parnt) = N_Accept_Alternative - and then Curr = Accept_Statement (Parnt) - then - if Present (Accept_Handler_Records (Parnt)) then - Hlist := Accept_Handler_Records (Parnt); - else - Hlist := New_List; - Set_Accept_Handler_Records (Parnt, Hlist); - end if; - - return True; - else - Curr := Parnt; - Parnt := Parent (Parnt); - end if; - end loop; - - return False; - end Inside_Selective_Accept; - - --------------- - -- Set_Hlist -- - --------------- - - procedure Set_Hlist is - begin - -- Never try to inline a subprogram with exception handlers - - Set_Is_Inlined (Subp_Entity, False); - - if Present (Subp_Entity) - and then Present (Handler_Records (Subp_Entity)) - then - Hlist := Handler_Records (Subp_Entity); - else - Hlist := New_List; - Set_Handler_Records (Subp_Entity, Hlist); - end if; - end Set_Hlist; - - -- Start of processing for Expand_Exception_Handler_Tables - - begin - -- Nothing to do if this handler has already been processed - - if Zero_Cost_Handling (HSS) then - return; - end if; - - Set_Zero_Cost_Handling (HSS); - - -- Find the parent subprogram or package scope containing this - -- exception frame. This should always find a real package or - -- subprogram. If it does not it will stop at Standard, but - -- this cannot legitimately occur. - - -- We only stop at library level packages, for inner packages - -- we always attach handlers to the containing procedure. - - Subp_Entity := Current_Scope; - Scope_Loop : loop - - -- Never need tables expanded inside a generic template - - if Is_Generic_Unit (Subp_Entity) then - return; - - -- Stop if we reached containing subprogram. Go to protected - -- subprogram if there is one defined. - - elsif Ekind (Subp_Entity) = E_Function - or else Ekind (Subp_Entity) = E_Procedure - then - if Present (Protected_Body_Subprogram (Subp_Entity)) then - Subp_Entity := Protected_Body_Subprogram (Subp_Entity); - end if; - - Set_Hlist; - exit Scope_Loop; - - -- Case of within an entry - - elsif Is_Entry (Subp_Entity) then - - -- Protected entry, use corresponding body subprogram - - if Present (Protected_Body_Subprogram (Subp_Entity)) then - Subp_Entity := Protected_Body_Subprogram (Subp_Entity); - Set_Hlist; - exit Scope_Loop; - - -- Check if we are within a selective accept alternative - - elsif Inside_Selective_Accept then - - -- As a side effect, Inside_Selective_Accept set Hlist, - -- in much the same manner as Set_Hlist, except that - -- the list involved was the one for the selective accept. - - exit Scope_Loop; - end if; - - -- Case of within library level package - - elsif Ekind (Subp_Entity) = E_Package - and then Is_Compilation_Unit (Subp_Entity) - then - if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then - Subp_Entity := Body_Entity (Subp_Entity); - end if; - - Set_Hlist; - exit Scope_Loop; - - -- Task type case - - elsif Ekind (Subp_Entity) = E_Task_Type then - - -- Check if we are within a selective accept alternative - - if Inside_Selective_Accept then - - -- As a side effect, Inside_Selective_Accept set Hlist, - -- in much the same manner as Set_Hlist, except that the - -- list involved was the one for the selective accept. - - exit Scope_Loop; - - -- Stop if we reached task type with task body procedure, - -- use the task body procedure. - - elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then - Subp_Entity := Get_Task_Body_Procedure (Subp_Entity); - Set_Hlist; - exit Scope_Loop; - end if; - end if; - - -- If we fall through, keep looking - - Subp_Entity := Scope (Subp_Entity); - end loop Scope_Loop; - - pragma Assert (Subp_Entity /= Standard_Standard); - - -- Analyze standard labels - - Analyze_Label_Entity (L1); - Analyze_Label_Entity (L2); - - Insert_Before_And_Analyze (First (Stms), - Make_Label (Loc, - Identifier => New_Occurrence_Of (L1, Loc))); - Set_Exception_Junk (First (Stms)); - - Append_To_Stms ( - Make_Label (Loc, - Identifier => New_Occurrence_Of (L2, Loc))); - - -- Loop through exception handlers - - Handler := First_Non_Pragma (Handlrs); - while Present (Handler) loop - Set_Zero_Cost_Handling (Handler); - - -- Add label at start of handler, and goto at the end - - Lnn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Analyze_Label_Entity (Lnn); - - Item := - Make_Label (Loc, - Identifier => New_Occurrence_Of (Lnn, Loc)); - Set_Exception_Junk (Item); - Insert_Before_And_Analyze (First (Statements (Handler)), Item); - - -- Loop through choices - - Choice := First (Exception_Choices (Handler)); - while Present (Choice) loop - - -- Others (or all others) choice - - if Nkind (Choice) = N_Others_Choice then - if All_Others (Choice) then - E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc); - else - E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc); - end if; - - -- Special case of VMS_Exception. Not clear what we will do - -- eventually here if and when we implement zero cost exceptions - -- on VMS. But at least for now, don't blow up trying to take - -- a garbage code address for such an exception. - - elsif Is_VMS_Exception (Entity (Choice)) then - E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc); - - -- Normal case of specific exception choice - - else - E_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Entity (Choice), Loc), - Attribute_Name => Name_Identity); - end if; - - HR_Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('H')); - - HL_Ref := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (HR_Ent, Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- Now we need to add the entry for the new handler record to - -- the list of handler records for the current subprogram. - - -- Normally we end up generating the handler records in exactly - -- the right order. Here right order means innermost first, - -- since the table will be searched sequentially. Since we - -- generally expand from outside to inside, the order is just - -- what we want, and we need to append the new entry to the - -- end of the list. - - -- However, there are exceptions, notably in the case where - -- a generic body is inserted later on. See for example the - -- case of ACVC test C37213J, which has the following form: - - -- generic package x ... end x; - -- package body x is - -- begin - -- ... - -- exception (1) - -- ... - -- end x; - - -- ... - - -- declare - -- package q is new x; - -- begin - -- ... - -- exception (2) - -- ... - -- end; - - -- In this case, we will expand exception handler (2) first, - -- since the expansion of (1) is delayed till later when the - -- generic body is inserted. But (1) belongs before (2) in - -- the chain. - - -- Note that scopes are not totally ordered, because two - -- scopes can be in parallel blocks, so that it does not - -- matter what order these entries appear in. An ordering - -- relation exists if one scope is inside another, and what - -- we really want is some partial ordering. - - -- A simple, not very efficient, but adequate algorithm to - -- achieve this partial ordering is to search the list for - -- the first entry containing the given scope, and put the - -- new entry just before it. - - declare - New_Scop : constant Entity_Id := Current_Scope; - Ent : Node_Id; - - begin - Ent := First (Hlist); - loop - -- If all searched, then we can just put the new - -- entry at the end of the list (it actually does - -- not matter where we put it in this case). - - if No (Ent) then - Append_To (Hlist, HL_Ref); - exit; - - -- If the current scope is within the scope of the - -- entry then insert the entry before to retain the - -- proper order as per above discussion. - - -- Note that for equal entries, we just keep going, - -- which is fine, the entry will end up at the end - -- of the list where it belongs. - - elsif Scope_Within - (New_Scop, Scope (Entity (Prefix (Ent)))) - then - Insert_Before (Ent, HL_Ref); - exit; - - -- Otherwise keep looking - - else - Next (Ent); - end if; - end loop; - end; - - Item := - Make_Object_Declaration (Loc, - Defining_Identifier => HR_Ent, - Constant_Present => True, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Handler_Record), Loc), - - Expression => - Make_Aggregate (Loc, - Expressions => New_List ( - Make_Attribute_Reference (Loc, -- Lo - Prefix => New_Occurrence_Of (L1, Loc), - Attribute_Name => Name_Address), - - Make_Attribute_Reference (Loc, -- Hi - Prefix => New_Occurrence_Of (L2, Loc), - Attribute_Name => Name_Address), - - E_Id, -- Id - - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler - Attribute_Name => Name_Address)))); - - Set_Handler_List_Entry (Item, HL_Ref); - Set_Exception_Junk (Item); - Insert_After_And_Analyze (Last (Statements (Handler)), Item); - Set_Is_Statically_Allocated (HR_Ent); - - -- If this is a late insertion (from body instance) it is being - -- inserted in the component list of an already analyzed aggre- - -- gate, and must be analyzed explicitly. - - Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr)); - - Next (Choice); - end loop; - - Next_Non_Pragma (Handler); - end loop; - end Expand_Exception_Handler_Tables; - ------------------------------- -- Expand_Exception_Handlers -- ------------------------------- @@ -850,13 +326,6 @@ package body Exp_Ch11 is then Set_Exception_Handlers (HSS, No_List); end if; - - -- The last step for expanding exception handlers is to expand the - -- exception tables if zero cost exception handling is active. - - if Exception_Mechanism = Front_End_ZCX_Exceptions then - Expand_Exception_Handler_Tables (HSS); - end if; end Expand_Exception_Handlers; ------------------------------------ @@ -1331,574 +800,6 @@ package body Exp_Ch11 is Analyze_And_Resolve (N, RTE (RE_Code_Loc)); end Expand_N_Subprogram_Info; - ------------------------------------ - -- Generate_Subprogram_Descriptor -- - ------------------------------------ - - procedure Generate_Subprogram_Descriptor - (N : Node_Id; - Loc : Source_Ptr; - Spec : Entity_Id; - Slist : List_Id) - is - Code : Node_Id; - Ent : Entity_Id; - Decl : Node_Id; - Dtyp : Entity_Id; - Numh : Nat; - Sdes : Node_Id; - Hrc : List_Id; - - begin - if Exception_Mechanism /= Front_End_ZCX_Exceptions then - return; - end if; - - if Restriction_Active (No_Exception_Handlers) then - return; - end if; - - -- Suppress descriptor if we are not generating code. This happens - -- in the case of a -gnatc -gnatt compilation where we force generics - -- to be generated, but we still don't want exception tables. - - if Operating_Mode /= Generate_Code then - return; - end if; - - -- Suppress descriptor if we are in No_Exceptions restrictions mode, - -- since we can never propagate exceptions in any case in this mode. - -- The same consideration applies for No_Exception_Handlers (which - -- is also set in High_Integrity_Mode). - - if Restriction_Active (No_Exceptions) - or Restriction_Active (No_Exception_Handlers) - then - return; - end if; - - -- Suppress descriptor if we are inside a generic. There are two - -- ways that we can tell that, depending on what is going on. If - -- we are actually inside the processing for a generic right now, - -- then Expander_Active will be reset. If we are outside the - -- generic, then we will see the generic entity. - - if not Expander_Active then - return; - end if; - - -- Suppress descriptor is subprogram is marked as eliminated, for - -- example if this is a subprogram created to analyze a default - -- expression with potential side effects. Ditto if it is nested - -- within an eliminated subprogram, for example a cleanup action. - - declare - Scop : Entity_Id; - - begin - Scop := Spec; - while Scop /= Standard_Standard loop - if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then - return; - end if; - - Scop := Scope (Scop); - end loop; - end; - - -- Suppress descriptor for original protected subprogram (we will - -- be called again later to generate the descriptor for the actual - -- protected body subprogram.) This does not apply to barrier - -- functions which are there own protected subprogram. - - if Is_Subprogram (Spec) - and then Present (Protected_Body_Subprogram (Spec)) - and then Protected_Body_Subprogram (Spec) /= Spec - then - return; - end if; - - -- Suppress descriptors for packages unless they have at least one - -- handler. The binder will generate the dummy (no handler) descriptors - -- for elaboration procedures. We can't do it here, because we don't - -- know if an elaboration routine does in fact exist. - - -- If there is at least one handler for the package spec or body - -- then most certainly an elaboration routine must exist, so we - -- can safely reference it. - - if (Nkind (N) = N_Package_Declaration - or else - Nkind (N) = N_Package_Body) - and then No (Handler_Records (Spec)) - then - return; - end if; - - -- Suppress all subprogram descriptors for the file System.Exceptions. - -- We similarly suppress subprogram descriptors for Ada.Exceptions. - -- These are all init procs for types which cannot raise exceptions. - -- The reason this is done is that otherwise we get embarassing - -- elaboration dependencies. - - Get_Name_String (Unit_File_Name (Current_Sem_Unit)); - - if Name_Buffer (1 .. 12) = "s-except.ads" - or else - Name_Buffer (1 .. 12) = "a-except.ads" - then - return; - end if; - - -- Similarly, we need to suppress entries for System.Standard_Library, - -- since otherwise we get elaboration circularities. Again, this would - -- better be done with a Suppress_Initialization pragma :-) - - if Name_Buffer (1 .. 11) = "s-stalib.ad" then - return; - end if; - - -- For now, also suppress entries for s-stoele because we have - -- some kind of unexplained error there ??? - - if Name_Buffer (1 .. 11) = "s-stoele.ad" then - return; - end if; - - -- And also for g-htable, because it cannot raise exceptions, - -- and generates some kind of elaboration order problem. - - if Name_Buffer (1 .. 11) = "g-htable.ad" then - return; - end if; - - -- Suppress subprogram descriptor if already generated. This happens - -- in the case of late generation from Delay_Subprogram_Descriptors - -- beging set (where there is more than one instantiation in the list) - - if Has_Subprogram_Descriptor (Spec) then - return; - else - Set_Has_Subprogram_Descriptor (Spec); - end if; - - -- Never generate descriptors for inlined bodies - - if Analyzing_Inlined_Bodies then - return; - end if; - - -- Here we definitely are going to generate a subprogram descriptor - - declare - Hnum : Nat := Homonym_Number (Spec); - - begin - if Hnum = 1 then - Hnum := 0; - end if; - - Ent := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Spec), "SD", Hnum)); - end; - - if No (Handler_Records (Spec)) then - Hrc := Empty_List; - Numh := 0; - else - Hrc := Handler_Records (Spec); - Numh := List_Length (Hrc); - end if; - - New_Scope (Spec); - - -- We need a static subtype for the declaration of the subprogram - -- descriptor. For the case of 0-3 handlers we can use one of the - -- predefined subtypes in System.Exceptions. For more handlers, - -- we build our own subtype here. - - case Numh is - when 0 => - Dtyp := RTE (RE_Subprogram_Descriptor_0); - - when 1 => - Dtyp := RTE (RE_Subprogram_Descriptor_1); - - when 2 => - Dtyp := RTE (RE_Subprogram_Descriptor_2); - - when 3 => - Dtyp := RTE (RE_Subprogram_Descriptor_3); - - when others => - Dtyp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - -- Set the constructed type as global, since we will be - -- referencing the object that is of this type globally - - Set_Is_Statically_Allocated (Dtyp); - - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Dtyp, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Numh))))); - - Append (Decl, Slist); - - -- We analyze the descriptor for the subprogram and package - -- case, but not for the imported subprogram case (it will - -- be analyzed when the freeze entity actions are analyzed. - - if Present (N) then - Analyze (Decl); - end if; - - Set_Exception_Junk (Decl); - end case; - - -- Prepare the code address entry for the table entry. For the normal - -- case of being within a procedure, this is simply: - - -- P'Code_Address - - -- where P is the procedure, but for the package case, it is - - -- P'Elab_Body'Code_Address - -- P'Elab_Spec'Code_Address - - -- for the body and spec respectively. Note that we do our own - -- analysis of these attribute references, because we know in this - -- case that the prefix of ELab_Body/Spec is a visible package, - -- which can be referenced directly instead of using the general - -- case expansion for these attributes. - - if Ekind (Spec) = E_Package then - Code := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Spec, Loc), - Attribute_Name => Name_Elab_Spec); - Set_Etype (Code, Standard_Void_Type); - Set_Analyzed (Code); - - elsif Ekind (Spec) = E_Package_Body then - Code := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc), - Attribute_Name => Name_Elab_Body); - Set_Etype (Code, Standard_Void_Type); - Set_Analyzed (Code); - - else - Code := New_Occurrence_Of (Spec, Loc); - end if; - - Code := - Make_Attribute_Reference (Loc, - Prefix => Code, - Attribute_Name => Name_Code_Address); - - Set_Etype (Code, RTE (RE_Address)); - Set_Analyzed (Code); - - -- Now we can build the subprogram descriptor - - Sdes := - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Constant_Present => True, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Dtyp, Loc), - - Expression => - Make_Aggregate (Loc, - Expressions => New_List ( - Make_Integer_Literal (Loc, Numh), -- Num_Handlers - - Code, -- Code - --- temp code ??? - --- Make_Subprogram_Info (Loc, -- Subprogram_Info --- Identifier => --- New_Occurrence_Of (Spec, Loc)), - - New_Copy_Tree (Code), - - Make_Aggregate (Loc, -- Handler_Records - Expressions => Hrc)))); - - Set_Exception_Junk (Sdes); - Set_Is_Subprogram_Descriptor (Sdes); - - Append (Sdes, Slist); - - -- We analyze the descriptor for the subprogram and package case, - -- but not for the imported subprogram case (it will be analyzed - -- when the freeze entity actions are analyzed. - - if Present (N) then - Analyze (Sdes); - end if; - - -- We can now pop the scope used for analyzing the descriptor - - Pop_Scope; - - -- We need to set the descriptor as statically allocated, since - -- it will be referenced from the unit exception table. - - Set_Is_Statically_Allocated (Ent); - - -- Append the resulting descriptor to the list. We do this only - -- if we are in the main unit. You might think that we could - -- simply skip generating the descriptors completely if we are - -- not in the main unit, but in fact this is not the case, since - -- we have problems with inconsistent serial numbers for internal - -- names if we do this. - - if In_Extended_Main_Code_Unit (Spec) then - Append_To (SD_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Unrestricted_Access)); - - Unit_Exception_Table_Present := True; - end if; - - end Generate_Subprogram_Descriptor; - - ------------------------------------------------------------ - -- Generate_Subprogram_Descriptor_For_Imported_Subprogram -- - ------------------------------------------------------------ - - procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram - (Spec : Entity_Id; - Slist : List_Id) - is - begin - Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist); - end Generate_Subprogram_Descriptor_For_Imported_Subprogram; - - ------------------------------------------------ - -- Generate_Subprogram_Descriptor_For_Package -- - ------------------------------------------------ - - procedure Generate_Subprogram_Descriptor_For_Package - (N : Node_Id; - Spec : Entity_Id) - is - Adecl : Node_Id; - - begin - -- If N is empty with prior errors, ignore - - if Total_Errors_Detected /= 0 and then No (N) then - return; - end if; - - -- Do not generate if no exceptions - - if Restriction_Active (No_Exception_Handlers) then - return; - end if; - - -- Otherwise generate descriptor - - Adecl := Aux_Decls_Node (Parent (N)); - - if No (Actions (Adecl)) then - Set_Actions (Adecl, New_List); - end if; - - Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl)); - end Generate_Subprogram_Descriptor_For_Package; - - --------------------------------------------------- - -- Generate_Subprogram_Descriptor_For_Subprogram -- - --------------------------------------------------- - - procedure Generate_Subprogram_Descriptor_For_Subprogram - (N : Node_Id; - Spec : Entity_Id) - is - begin - -- If we have no subprogram body and prior errors, ignore - - if Total_Errors_Detected /= 0 and then No (N) then - return; - end if; - - -- Do not generate if no exceptions - - if Restriction_Active (No_Exception_Handlers) then - return; - end if; - - -- Else generate descriptor - - declare - HSS : constant Node_Id := Handled_Statement_Sequence (N); - - begin - if No (Exception_Handlers (HSS)) then - Generate_Subprogram_Descriptor - (N, Sloc (N), Spec, Statements (HSS)); - else - Generate_Subprogram_Descriptor - (N, Sloc (N), - Spec, Statements (Last (Exception_Handlers (HSS)))); - end if; - end; - end Generate_Subprogram_Descriptor_For_Subprogram; - - ----------------------------------- - -- Generate_Unit_Exception_Table -- - ----------------------------------- - - -- The only remaining thing to generate here is to generate the - -- reference to the subprogram descriptor chain. See Ada.Exceptions - -- for details of required data structures. - - procedure Generate_Unit_Exception_Table is - Loc : constant Source_Ptr := No_Location; - Num : Nat; - Decl : Node_Id; - Ent : Entity_Id; - Next_Ent : Entity_Id; - Stent : Entity_Id; - - begin - -- Nothing to be done if zero length exceptions not active - - if Exception_Mechanism /= Front_End_ZCX_Exceptions then - return; - end if; - - -- Nothing to do if no exceptions - - if Restriction_Active (No_Exception_Handlers) then - return; - end if; - - -- Remove any entries from SD_List that correspond to eliminated - -- subprograms. - - Ent := First (SD_List); - while Present (Ent) loop - Next_Ent := Next (Ent); - if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then - Remove (Ent); -- After this, there is no Next (Ent) anymore - end if; - - Ent := Next_Ent; - end loop; - - -- Nothing to do if no unit exception table present. - -- An empty table can result from subprogram elimination, - -- in such a case, eliminate the exception table itself. - - if Is_Empty_List (SD_List) then - Unit_Exception_Table_Present := False; - return; - end if; - - -- Do not generate table in a generic - - if Inside_A_Generic then - return; - end if; - - -- Generate the unit exception table - - -- subtype Tnn is Subprogram_Descriptors_Record (Num); - -- __gnat_unitname__SDP : aliased constant Tnn := - -- Num, - -- (sub1'unrestricted_access, - -- sub2'unrestricted_access, - -- ... - -- subNum'unrestricted_access)); - - Num := List_Length (SD_List); - - Stent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - Insert_Library_Level_Action ( - Make_Subtype_Declaration (Loc, - Defining_Identifier => Stent, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Subprogram_Descriptors_Record), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Num)))))); - - Set_Is_Statically_Allocated (Stent); - - Get_External_Unit_Name_String (Unit_Name (Main_Unit)); - Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); - Name_Buffer (1 .. 7) := "__gnat_"; - Name_Len := Name_Len + 7; - Add_Str_To_Name_Buffer ("__SDP"); - - Ent := - Make_Defining_Identifier (Loc, - Chars => Name_Find); - - Get_Name_String (Chars (Ent)); - Set_Interface_Name (Ent, - Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => New_Occurrence_Of (Stent, Loc), - Constant_Present => True, - Aliased_Present => True, - Expression => - Make_Aggregate (Loc, - New_List ( - Make_Integer_Literal (Loc, List_Length (SD_List)), - - Make_Aggregate (Loc, - Expressions => SD_List)))); - - Insert_Library_Level_Action (Decl); - - Set_Is_Exported (Ent, True); - Set_Is_Public (Ent, True); - Set_Is_Statically_Allocated (Ent, True); - - Get_Name_String (Chars (Ent)); - Set_Interface_Name (Ent, - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); - - end Generate_Unit_Exception_Table; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - SD_List := Empty_List; - end Initialize; - ---------------------- -- Is_Non_Ada_Error -- ---------------------- @@ -1922,59 +823,4 @@ package body Exp_Ch11 is return True; end Is_Non_Ada_Error; - ---------------------------- - -- Remove_Handler_Entries -- - ---------------------------- - - procedure Remove_Handler_Entries (N : Node_Id) is - function Check_Handler_Entry (N : Node_Id) return Traverse_Result; - -- This function checks one node for a possible reference to a - -- handler entry that must be deleted. it always returns OK. - - function Remove_All_Handler_Entries is new - Traverse_Func (Check_Handler_Entry); - -- This defines the traversal operation - - Discard : Traverse_Result; - pragma Warnings (Off, Discard); - - function Check_Handler_Entry (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Object_Declaration then - - if Present (Handler_List_Entry (N)) then - Remove (Handler_List_Entry (N)); - Delete_Tree (Handler_List_Entry (N)); - Set_Handler_List_Entry (N, Empty); - - elsif Is_Subprogram_Descriptor (N) then - declare - SDN : Node_Id; - - begin - SDN := First (SD_List); - while Present (SDN) loop - if Defining_Identifier (N) = Entity (Prefix (SDN)) then - Remove (SDN); - Delete_Tree (SDN); - exit; - end if; - - Next (SDN); - end loop; - end; - end if; - end if; - - return OK; - end Check_Handler_Entry; - - -- Start of processing for Remove_Handler_Entries - - begin - if Exception_Mechanism = Front_End_ZCX_Exceptions then - Discard := Remove_All_Handler_Entries (N); - end if; - end Remove_Handler_Entries; - end Exp_Ch11; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index 7b8641a..ff8e82c 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,9 +41,6 @@ package Exp_Ch11 is -- See runtime routine Ada.Exceptions for full details on the format and -- content of these tables. - procedure Initialize; - -- Initializes these data structures for a new main unit file - procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id); -- Given a handled statement sequence, HSS, for which the At_End_Proc -- field is set, and which currently has no exception handlers, this @@ -59,59 +56,9 @@ package Exp_Ch11 is -- is also called to expand the special exception handler built for -- accept bodies (see Exp_Ch9.Build_Accept_Body). - procedure Generate_Unit_Exception_Table; - -- Procedure called by main driver to generate unit exception table if - -- zero cost exceptions are enabled. See System.Exceptions for details. - function Is_Non_Ada_Error (E : Entity_Id) return Boolean; -- This function is provided for Gigi use. It returns True if operating on -- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error. -- This is used to generate the special matching code for this exception. - procedure Remove_Handler_Entries (N : Node_Id); - -- This procedure is called when optimization circuits determine that - -- an entire subtree can be removed. If the subtree contains handler - -- entries in zero cost exception mode, then such removal can lead to - -- dangling references to non-existent handlers in the handler table. - -- This procedure removes such references. - - -------------------------------------- - -- Subprogram_Descriptor Generation -- - -------------------------------------- - - -- Subprogram descriptors are required for all subprograms, including - -- explicit subprograms defined in the program, subprograms that are - -- imported via pragma Import, and also for the implicit elaboration - -- subprograms used to elaborate package specs and bodies. - - procedure Generate_Subprogram_Descriptor_For_Package - (N : Node_Id; - Spec : Entity_Id); - -- This is used to create a descriptor for the implicit elaboration - -- procedure for a package spec of body. The compiler only generates - -- such descriptors if the package spec or body contains exception - -- handlers (either explicitly in the case of a body, or from generic - -- package instantiations). N is the node for the package body or - -- spec, and Spec is the package body or package entity respectively. - -- N must be a compilation unit, and the descriptor is placed at - -- the end of the actions for the auxiliary compilation unit node. - - procedure Generate_Subprogram_Descriptor_For_Subprogram - (N : Node_Id; - Spec : Entity_Id); - -- This is used to create a desriptor for a subprogram, both those - -- present in the source, and those implicitly generated by code - -- expansion. N is the subprogram body node, and Spec is the entity - -- for the subprogram. The descriptor is placed at the end of the - -- Last exception handler, or, if there are no handlers, at the end - -- of the statement sequence. - - procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram - (Spec : Entity_Id; - Slist : List_Id); - -- This is used to create a descriptor for an imported subprogram. - -- Such descriptors are needed for propagation of exceptions through - -- such subprograms. The descriptor never references any handlers, - -- and is appended to the given Slist. - end Exp_Ch11; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 316c34e..31f5bb1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; -with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; @@ -3365,9 +3364,6 @@ package body Freeze is if Result = No_List then Result := Empty_List; end if; - - Generate_Subprogram_Descriptor_For_Imported_Subprogram - (E, Result); end if; end if; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 382d41e..51112c5 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,6 @@ with Checks; with CStand; with Debug; use Debug; with Elists; -with Exp_Ch11; with Exp_Dbug; with Fmap; with Fname.UF; @@ -80,7 +79,6 @@ begin Lib.Load.Initialize; Sem_Ch8.Initialize; Fname.UF.Initialize; - Exp_Ch11.Initialize; Checks.Initialize; -- Create package Standard @@ -329,11 +327,6 @@ begin end if; Check_Elab_Calls; - - -- Build unit exception table. We leave this up to the end to - -- make sure that all the necessary information is at hand. - - Exp_Ch11.Generate_Unit_Exception_Table; end if; -- List library units if requested diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 44e3631..32720d5 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -203,27 +203,7 @@ begin if Targparm.ZCX_By_Default_On_Target then if Targparm.GCC_ZCX_Support_On_Target then - Exception_Mechanism := Back_End_ZCX_Exceptions; - else - Exception_Mechanism := Front_End_ZCX_Exceptions; - end if; - end if; - - -- We take the command line exception mechanism into account - - if Opt.Zero_Cost_Exceptions_Set then - if Opt.Zero_Cost_Exceptions_Val = False then - Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions; - - elsif Debug_Flag_XX then - Exception_Mechanism := Front_End_ZCX_Exceptions; - - elsif Targparm.GCC_ZCX_Support_On_Target then - Exception_Mechanism := Back_End_ZCX_Exceptions; - - elsif Targparm.Front_End_ZCX_Support_On_Target then - Exception_Mechanism := Front_End_ZCX_Exceptions; - + Exception_Mechanism := Back_End_Exceptions; else Osint.Fail ("Zero Cost Exceptions not supported on this target"); diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 05ee3ca..e5f0bf2 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; -with Exp_Ch11; use Exp_Ch11; with Exp_Tss; use Exp_Tss; with Fname; use Fname; with Fname.UF; use Fname.UF; @@ -986,29 +985,6 @@ package body Inline is and then not Is_Generic_Unit (Main_Unit_Entity) then Cleanup_Scopes; - - -- Also generate subprogram descriptors that were delayed - - for J in Pending_Descriptor.First .. Pending_Descriptor.Last loop - declare - Ent : constant Entity_Id := Pending_Descriptor.Table (J); - - begin - if Is_Subprogram (Ent) then - Generate_Subprogram_Descriptor_For_Subprogram - (Get_Subprogram_Body (Ent), Ent); - - elsif Ekind (Ent) = E_Package then - Generate_Subprogram_Descriptor_For_Package - (Parent (Declaration_Node (Ent)), Ent); - - elsif Ekind (Ent) = E_Package_Body then - Generate_Subprogram_Descriptor_For_Package - (Declaration_Node (Ent), Ent); - end if; - end; - end loop; - elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then End_Generic; end if; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 71e6ff8..3812478 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,7 +63,7 @@ package Lib.Writ is -- If the following guidelines are respected, downward compatibility -- problems (old tools reading new ali files) should be minimized: - -- The basic key character format must be kept. + -- The basic key character format must be kept -- The V line must be the first line, this is checked by ali.adb -- even in Ignore_Errors mode, and is used to verify that the file @@ -233,10 +233,6 @@ package Lib.Writ is -- UA Unreserve_All_Interrupts pragma was processed in one or -- more units in this file -- - -- UX Generated code contains unit exception table pointer - -- (i.e. it uses zero-cost exceptions, and there is at - -- least one subprogram present). - -- -- ZX Units in this file use zero-cost exceptions and have -- generated exception tables. If ZX is not present, the -- longjmp/setjmp exception scheme is in use. @@ -390,7 +386,7 @@ package Lib.Writ is -- -- U Unit Header -- -- -------------------- - -- The lines for each compilation unit have the following form. + -- The lines for each compilation unit have the following form -- U unit-name source-name version <> -- diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index a673f2b..a5d476c 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,6 @@ with Atree; use Atree; with Einfo; use Einfo; with Fname; use Fname; with Namet; use Namet; -with Namet; use Namet; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -827,7 +826,6 @@ package body Lib is Linker_Option_Lines.Init; Load_Stack.Init; Units.Init; - Unit_Exception_Table_Present := False; Compilation_Switches.Init; end Initialize; diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index 7087c1c..5dd2692 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -31,16 +31,18 @@ ****************************************************************************/ +/* C counterparts of what System.Standard_Library defines. */ + typedef unsigned Exception_Code; -/* C counterpart of what System.Standard_Library defines. */ struct Exception_Data { - char Handled_By_Others; + char Not_Handled_By_Others; char Lang; int Name_Length; - char *Full_Name, Htable_Ptr; + char *Full_Name, *Htable_Ptr; Exception_Code Import_Code; + void (*Raise_Hook)(void); }; typedef struct Exception_Data *Exception_Id; diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads deleted file mode 100644 index ea9d8bf..0000000 --- a/gcc/ada/s-except.ads +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains definitions used for zero cost exception handling. --- See unit Ada.Exceptions for further details. Note that the reason that --- we separate out these definitions is to avoid problems with recursion --- in rtsfind. They must be in a unit which does not require any exception --- table generation of any kind. - -with Ada.Exceptions; - -with System; -with System.Standard_Library; - -with Unchecked_Conversion; - -package System.Exceptions is - - package SSL renames System.Standard_Library; - package AEX renames Ada.Exceptions; - - -- The following section defines data structures used for zero cost - -- exception handling if System.Parameters.Zero_Cost_Exceptions is - -- set true (i.e. zero cost exceptions are implemented on this target). - - -- The approach is to build tables that describe the PC ranges that - -- are covered by various exception frames. When an exception occurs, - -- these tables are searched to determine the address of the applicable - -- handler for the current exception. - - subtype Handler_Loc is System.Address; - -- Code location representing entry address of a handler. Values of - -- this type are created using the N_Handler_Loc node, and then - -- passed to the Enter_Handler procedure to enter a handler. - - subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call - -- addresses when propagating an exception (also traceback table) - -- Values of this type are created by using Label'Address or - -- extracted from machine states using Get_Code_Loc. - - -------------------- - -- Handler_Record -- - -------------------- - - -- A Handler record is built for each choice for each exception handler - -- in a frame. - - function To_Exception_Id is - new Unchecked_Conversion (SSL.Exception_Data_Ptr, AEX.Exception_Id); - - Others_Dummy_Exception : aliased SSL.Exception_Data; - Others_Id : constant AEX.Exception_Id := - To_Exception_Id (Others_Dummy_Exception'Access); - -- Dummy exception used to signal others exception - - All_Others_Dummy_Exception : aliased SSL.Exception_Data; - All_Others_Id : constant AEX.Exception_Id := - To_Exception_Id (All_Others_Dummy_Exception'Access); - -- Dummy exception used to signal all others exception (including - -- exceptions not normally handled by others, e.g. Abort_Signal) - - type Handler_Record is record - Lo : Code_Loc; - Hi : Code_Loc; - -- Range of PC values of code covered by this handler record. The - -- handler covers all code addresses that are greater than the Lo - -- value, and less than or equal to the Hi value. - - Id : AEX.Exception_Id; - -- Id of exception being handled, or one of the above special values - - Handler : Handler_Loc; - -- Address of label at start of handler - end record; - - type Handler_Record_Ptr is access all Handler_Record; - type Handler_Record_List is array (Natural range <>) of Handler_Record_Ptr; - - --------------------------- - -- Subprogram_Descriptor -- - --------------------------- - - -- A Subprogram_Descriptor is built for each subprogram through which - -- exceptions may propagate, this includes all Ada subprograms, - -- and also all foreign language imported subprograms. - - subtype Subprogram_Info_Type is System.Address; - -- This type is used to represent a value that is used to unwind stack - -- frames. It references target dependent data that provides sufficient - -- information (e.g. about the location of the return point, use of a - -- frame pointer, save-over-call registers etc) to unwind the machine - -- state to the caller. For some targets, this is simply a pointer to - -- the entry point of the procedure (and the routine to pop the machine - -- state disassembles the code at the entry point to obtain the required - -- information). On other targets, it is a pointer to data created by the - -- backend or assembler to represent the required information. - - No_Info : constant Subprogram_Info_Type := System.Null_Address; - -- This is a special value used to indicate that it is not possible - -- to pop past this frame. This is used at the outer level (e.g. for - -- package elaboration procedures or the main procedure), and for any - -- other foreign language procedure for which propagation is known - -- to be impossible. An exception is considered unhandled if an - -- attempt is made to pop a frame whose Subprogram_Info_Type value - -- is set to No_Info. - - type Subprogram_Descriptor (Num_Handlers : Natural) is record - Code : Code_Loc; - -- This is a code location used to determine which procedure we are - -- in. Most usually it is simply the entry address for the procedure. - -- hA given address is considered to be within the procedure referenced - -- by a Subprogram_Descriptor record if this is the descriptor for - -- which the Code value is as large as possible without exceeding - -- the given value. - - Subprogram_Info : Subprogram_Info_Type; - -- This is a pointer to a target dependent data item that provides - -- sufficient information for unwinding the stack frame of this - -- procedure. A value of No_Info (zero) means that we are the - -- outer level procedure. - - Handler_Records : Handler_Record_List (1 .. Num_Handlers); - -- List of pointers to Handler_Records for this procedure. The array - -- is sorted inside out, i.e. entries for inner frames appear before - -- entries for outer handlers. This ensures that a serial search - -- finds the innermost applicable handler - end record; - - subtype Subprogram_Descriptor_0 is Subprogram_Descriptor (0); - subtype Subprogram_Descriptor_1 is Subprogram_Descriptor (1); - subtype Subprogram_Descriptor_2 is Subprogram_Descriptor (2); - subtype Subprogram_Descriptor_3 is Subprogram_Descriptor (3); - -- Predeclare commonly used subtypes for buildingt he tables - - type Subprogram_Descriptor_Ptr is access all Subprogram_Descriptor; - - type Subprogram_Descriptor_List - is array (Natural range <>) of Subprogram_Descriptor_Ptr; - - type Subprogram_Descriptors_Record (Count : Natural) is record - SDesc : Subprogram_Descriptor_List (1 .. Count); - end record; - - type Subprogram_Descriptors_Ptr is - access all Subprogram_Descriptors_Record; - - -------------------------- - -- Unit Exception_Table -- - -------------------------- - - -- If a unit contains at least one subprogram, then a library level - -- declaration of the form: - - -- Tnn : aliased constant Subprogram_Descriptors := - -- (Count => n, - -- SDesc => - -- (SD1'Unrestricted_Access, - -- SD2'Unrestricted_Access, - -- ... - -- SDn'Unrestricted_Access)); - -- pragma Export (Ada, Tnn, "__gnat_unit_name__SDP"); - - -- is generated where the initializing expression is an array aggregate - -- whose elements are pointers to the generated subprogram descriptors - -- for the units. - - -- Note: the ALI file contains the designation UX in each unit entry - -- if a unit exception table is generated. - - -- The binder generates a list of addresses of pointers to these tables. - -end System.Exceptions; diff --git a/gcc/ada/s-mastop-irix.adb b/gcc/ada/s-mastop-irix.adb index 80f0d59..cda22fa 100644 --- a/gcc/ada/s-mastop-irix.adb +++ b/gcc/ada/s-mastop-irix.adb @@ -44,7 +44,6 @@ with Unchecked_Conversion; package body System.Machine_State_Operations is use System.Storage_Elements; - use System.Exceptions; -- The exc_unwind function in libexc operats on a Sigcontext @@ -182,66 +181,6 @@ package body System.Machine_State_Operations is (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements)); end Allocate_Machine_State; - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - pragma Warnings (Off, M); - pragma Warnings (Off, Handler); - - LOADI : constant String (1 .. 2) := 'l' & LSC; - -- This is "lw" in o32 mode, and "ld" in n32/n64 mode - - LOADF : constant String (1 .. 4) := 'l' & LSC & "c1"; - -- This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode - - begin - -- Restore integer registers from machine state. Note that we know - -- that $4 points to M, and $5 points to Handler, since this is - -- the standard calling sequence - - Asm (LOADI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - - -- Restore floating-point registers from machine state - - Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - - -- Jump directly to the handler - - Asm ("jr $5"); - end Enter_Handler; - ---------------- -- Fetch_Code -- ---------------- @@ -284,12 +223,7 @@ package body System.Machine_State_Operations is -- Pop_Frame -- --------------- - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - + procedure Pop_Frame (M : Machine_State) is Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0); @@ -407,21 +341,7 @@ package body System.Machine_State_Operations is -- This pop operation will properly set the PC value in the machine -- state, so there is no need to save PC in the above code. - Pop_Frame (M, Set_Machine_State'Address); + Pop_Frame (M); end Set_Machine_State; - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - begin - null; - end Set_Signal_Machine_State; - end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-tru64.adb b/gcc/ada/s-mastop-tru64.adb index c788817..1a7b987 100644 --- a/gcc/ada/s-mastop-tru64.adb +++ b/gcc/ada/s-mastop-tru64.adb @@ -39,8 +39,6 @@ with System.Memory; package body System.Machine_State_Operations is - use System.Exceptions; - pragma Linker_Options ("-lexc"); -- Needed for definitions of exc_capture_context and exc_virtual_unwind @@ -59,18 +57,6 @@ package body System.Machine_State_Operations is (Memory.Alloc (Memory.size_t (c_machine_state_length))); end Allocate_Machine_State; - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc); - pragma Import (C, c_enter_handler, "__gnat_enter_handler"); - - begin - c_enter_handler (M, Handler); - end Enter_Handler; - ---------------- -- Fetch_Code -- ---------------- @@ -135,12 +121,7 @@ package body System.Machine_State_Operations is -- Pop_Frame -- --------------- - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - + procedure Pop_Frame (M : Machine_State) is procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State); pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind"); @@ -178,21 +159,7 @@ package body System.Machine_State_Operations is pragma Import (C, c_capture_context, "exc_capture_context"); begin c_capture_context (M); - Pop_Frame (M, System.Null_Address); + Pop_Frame (M); end Set_Machine_State; - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - begin - null; - end Set_Signal_Machine_State; - end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-vms.adb b/gcc/ada/s-mastop-vms.adb index 764fe08..9e86728 100644 --- a/gcc/ada/s-mastop-vms.adb +++ b/gcc/ada/s-mastop-vms.adb @@ -41,7 +41,6 @@ with Unchecked_Conversion; package body System.Machine_State_Operations is - use System.Exceptions; subtype Cond_Value_Type is Unsigned_Longword; -- Record layouts copied from Starlet. @@ -148,48 +147,6 @@ package body System.Machine_State_Operations is (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); end Allocate_Machine_State; - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - procedure Get_Invo_Context ( - Result : out Unsigned_Longword; -- return value - Invo_Handle : Invo_Handle_Type; - Invo_Context : out Invo_Context_Blk_Type); - - pragma Interface (External, Get_Invo_Context); - - pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", - (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Value, Reference)); - - ICB : Invo_Context_Blk_Type; - - procedure Goto_Unwind ( - Status : out Cond_Value_Type; -- return value - Target_Invo : Address := Address_Zero; - Target_PC : Address := Address_Zero; - New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter; - New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter); - - pragma Interface (External, Goto_Unwind); - - pragma Import_Valued_Procedure - (Goto_Unwind, "SYS$GOTO_UNWIND", - (Cond_Value_Type, Address, Address, - Unsigned_Quadword, Unsigned_Quadword), - (Value, Reference, Reference, - Reference, Reference)); - - Status : Cond_Value_Type; - - begin - Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); - Goto_Unwind - (Status, System.Address (To_Invo_Handle_Access (M).all), Handler); - end Enter_Handler; - ---------------- -- Fetch_Code -- ---------------- @@ -261,12 +218,7 @@ package body System.Machine_State_Operations is -- Pop_Frame -- --------------- - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - + procedure Pop_Frame (M : Machine_State) is procedure Get_Prev_Invo_Handle ( Result : out Invo_Handle_Type; -- return value ICB : in Invo_Handle_Type); @@ -321,18 +273,4 @@ package body System.Machine_State_Operations is Pop_Frame (M, System.Null_Address); end Set_Machine_State; - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - begin - null; - end Set_Signal_Machine_State; - end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-x86.adb b/gcc/ada/s-mastop-x86.adb deleted file mode 100644 index 9f18229..0000000 --- a/gcc/ada/s-mastop-x86.adb +++ /dev/null @@ -1,594 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for x86) -- --- -- --- Copyright (C) 1999-2004 Ada Core Technologies, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: it is very important that this unit not generate any exception --- tables of any kind. Otherwise we get a nasty rtsfind recursion problem. --- This means no subprograms, including implicitly generated ones. - -with Unchecked_Conversion; -with System.Storage_Elements; -with System.Machine_Code; use System.Machine_Code; -with System.Memory; - -package body System.Machine_State_Operations is - - function "+" (Left, Right : Address) return Address; - pragma Import (Intrinsic, "+"); - -- Provide addition operation on type Address (this may not be directly - -- available if type System.Address is non-private and the operations on - -- the type are made abstract to hide them from public users of System). - - use System.Exceptions; - - type Uns8 is mod 2 ** 8; - type Uns32 is mod 2 ** 32; - - type Bits5 is mod 2 ** 5; - type Bits6 is mod 2 ** 6; - - function To_Address is new Unchecked_Conversion (Uns32, Address); - - type Uns32_Ptr is access all Uns32; - function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr); - - -- Note: the type Uns32 has an alignment of 4. However, in some cases - -- values of type Uns32_Ptr will not be aligned (notably in the case - -- where we get the immediate field from an instruction). However this - -- does not matter in practice, since the x86 does not require that - -- operands be aligned. - - ---------------------- - -- General Approach -- - ---------------------- - - -- For the x86 version of this unit, the Subprogram_Info_Type values - -- are simply the starting code address for the subprogram. Popping - -- of stack frames works by analyzing the code in the prolog, and - -- deriving from this analysis the necessary information for restoring - -- the registers, including the return point. - - --------------------------- - -- Description of Prolog -- - --------------------------- - - -- If a frame pointer is present, the prolog looks like - - -- pushl %ebp - -- movl %esp,%ebp - -- subl $nnn,%esp omitted if nnn = 0 - -- pushl %edi omitted if edi not used - -- pushl %esi omitted if esi not used - -- pushl %ebx omitted if ebx not used - - -- If a frame pointer is not present, the prolog looks like - - -- subl $nnn,%esp omitted if nnn = 0 - -- pushl %ebp omitted if ebp not used - -- pushl %edi omitted if edi not used - -- pushl %esi omitted if esi not used - -- pushl %ebx omitted if ebx not used - - -- Note: any or all of the save over call registers may be used and - -- if so, will be saved using pushl as shown above. The order of the - -- pushl instructions will be as shown above for gcc generated code, - -- but the code in this unit does not assume this. - - ------------------------- - -- Description of Call -- - ------------------------- - - -- A call looks like: - - -- pushl ... push parameters - -- pushl ... - -- call ... perform the call - -- addl $nnn,%esp omitted if no parameters - - -- Note that we are not absolutely guaranteed that the call is always - -- followed by an addl operation that readjusts %esp for this particular - -- call. There are two reasons for this: - - -- 1) The addl can be delayed and combined in the case where more than - -- one call appears in sequence. This can be suppressed by using the - -- switch -fno-defer-pop and for Ada code, we automatically use - -- this switch, but we could still be dealing with C code that was - -- compiled without using this switch. - - -- 2) Scheduling may result in moving the addl instruction away from - -- the call. It is not clear if this actually can happen at the - -- current time, but it is certainly conceptually possible. - - -- The addl after the call is important, since we need to be able to - -- restore the proper %esp value when we pop the stack. However, we do - -- not try to compensate for either of the above effects. As noted above, - -- case 1 does not occur for Ada code, and it does not appear in practice - -- that case 2 occurs with any significant frequency (we have never seen - -- an example so far for gcc generated code). - - -- Furthermore, it is only in the case of -fomit-frame-pointer that we - -- really get into trouble from not properly restoring %esp. If we have - -- a frame pointer, then the worst that happens is that %esp is slightly - -- more depressed than it should be. This could waste a bit of space on - -- the stack, and even in some cases cause a storage leak on the stack, - -- but it will not affect the functional correctness of the processing. - - ---------------------------------------- - -- Definitions of Instruction Formats -- - ---------------------------------------- - - type Rcode is (eax, ecx, edx, ebx, esp, ebp, esi, edi); - pragma Warnings (Off, Rcode); - -- Code indicating which register is referenced in an instruction - - -- The following define the format of a pushl instruction - - Op_pushl : constant Bits5 := 2#01010#; - - type Ins_pushl is record - Op : Bits5 := Op_pushl; - Reg : Rcode; - end record; - - for Ins_pushl use record - Op at 0 range 3 .. 7; - Reg at 0 range 0 .. 2; - end record; - - Ins_pushl_ebp : constant Ins_pushl := (Op_pushl, Reg => ebp); - - type Ins_pushl_Ptr is access all Ins_pushl; - - -- For the movl %esp,%ebp instruction, we only need to know the length - -- because we simply skip past it when we analyze the prolog. - - Ins_movl_length : constant := 2; - - -- The following define the format of addl/subl esp instructions - - Op_Immed : constant Bits6 := 2#100000#; - - Op2_addl_Immed : constant Bits5 := 2#11100#; - pragma Unreferenced (Op2_addl_Immed); - - Op2_subl_Immed : constant Bits5 := 2#11101#; - - type Word_Byte is (Word, Byte); - pragma Unreferenced (Byte); - - type Ins_addl_subl_byte is record - Op : Bits6; -- Set to Op_Immed - w : Word_Byte; -- Word/Byte flag (set to 1 = byte) - s : Boolean; -- Sign extension bit (1 = extend) - Op2 : Bits5; -- Secondary opcode - Reg : Rcode; -- Register - Imm8 : Uns8; -- Immediate operand - end record; - - for Ins_addl_subl_byte use record - Op at 0 range 2 .. 7; - w at 0 range 1 .. 1; - s at 0 range 0 .. 0; - Op2 at 1 range 3 .. 7; - Reg at 1 range 0 .. 2; - Imm8 at 2 range 0 .. 7; - end record; - - type Ins_addl_subl_word is record - Op : Bits6; -- Set to Op_Immed - w : Word_Byte; -- Word/Byte flag (set to 0 = word) - s : Boolean; -- Sign extension bit (1 = extend) - Op2 : Bits5; -- Secondary opcode - Reg : Rcode; -- Register - Imm32 : Uns32; -- Immediate operand - end record; - - for Ins_addl_subl_word use record - Op at 0 range 2 .. 7; - w at 0 range 1 .. 1; - s at 0 range 0 .. 0; - Op2 at 1 range 3 .. 7; - Reg at 1 range 0 .. 2; - Imm32 at 2 range 0 .. 31; - end record; - - type Ins_addl_subl_byte_Ptr is access all Ins_addl_subl_byte; - type Ins_addl_subl_word_Ptr is access all Ins_addl_subl_word; - - --------------------- - -- Prolog Analysis -- - --------------------- - - -- The analysis of the prolog answers the following questions: - - -- 1. Is %ebp used as a frame pointer? - -- 2. How far is SP depressed (i.e. what is the stack frame size) - -- 3. Which registers are saved in the prolog, and in what order - - -- The following data structure stores the answers to these questions - - subtype SOC is Rcode range ebx .. edi; - -- Possible save over call registers - - SOC_Max : constant := 4; - -- Max number of SOC registers that can be pushed - - type SOC_Push_Regs_Type is array (1 .. 4) of Rcode; - -- Used to hold the register codes of pushed SOC registers - - type Prolog_Type is record - - Frame_Reg : Boolean; - -- This is set to True if %ebp is used as a frame register, and - -- False otherwise (in the False case, %ebp may be saved in the - -- usual manner along with the other SOC registers). - - Frame_Length : Uns32; - -- Amount by which ESP is decremented on entry, includes the effects - -- of push's of save over call registers as indicated above, e.g. if - -- the prolog of a routine is: - -- - -- pushl %ebp - -- movl %esp,%ebp - -- subl $424,%esp - -- pushl %edi - -- pushl %esi - -- pushl %ebx - -- - -- Then the value of Frame_Length would be 436 (424 + 3 * 4). A - -- precise definition is that it is: - -- - -- %esp on entry minus %esp after last SOC push - -- - -- That definition applies both in the frame pointer present and - -- the frame pointer absent cases. - - Num_SOC_Push : Integer range 0 .. SOC_Max; - -- Number of save over call registers actually saved by pushl - -- instructions (other than the initial pushl to save the frame - -- pointer if a frame pointer is in use). - - SOC_Push_Regs : SOC_Push_Regs_Type; - -- The First Num_SOC_Push entries of this array are used to contain - -- the codes for the SOC registers, in the order in which they were - -- pushed. Note that this array excludes %ebp if it is used as a frame - -- register, since although %ebp is still considered an SOC register - -- in this case, it is saved and restored by a separate mechanism. - -- Also we will never see %esp represented in this list. Again, it is - -- true that %esp is saved over call, but it is restored by a separate - -- mechanism. - - end record; - - procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type); - -- Given the address of the start of the prolog for a procedure, - -- analyze the instructions of the prolog, and set Prolog to contain - -- the information obtained from this analysis. - - ---------------------------------- - -- Machine_State_Representation -- - ---------------------------------- - - -- The type Machine_State is defined in the body of Ada.Exceptions as - -- a Storage_Array of length 1 .. Machine_State_Length. But really it - -- has structure as defined here. We use the structureless declaration - -- in Ada.Exceptions to avoid this unit from being implementation - -- dependent. The actual definition of Machine_State is as follows: - - type SOC_Regs_Type is array (SOC) of Uns32; - - type MState is record - eip : Uns32; - -- The instruction pointer location (which is the return point - -- value from the next level down in all cases). - - Regs : SOC_Regs_Type; - -- Values of the save over call registers - end record; - - for MState use record - eip at 0 range 0 .. 31; - Regs at 4 range 0 .. 5 * 32 - 1; - end record; - -- Note: the routines Enter_Handler, and Set_Machine_State reference - -- the fields in this structure non-symbolically. - - type MState_Ptr is access all MState; - - function To_MState_Ptr is - new Unchecked_Conversion (Machine_State, MState_Ptr); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - use System.Storage_Elements; - - begin - return Machine_State - (Memory.Alloc (MState'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - -------------------- - -- Analyze_Prolog -- - -------------------- - - procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type) is - Ptr : Address; - Ppl : Ins_pushl_Ptr; - Pas : Ins_addl_subl_byte_Ptr; - - function To_Ins_pushl_Ptr is - new Unchecked_Conversion (Address, Ins_pushl_Ptr); - - function To_Ins_addl_subl_byte_Ptr is - new Unchecked_Conversion (Address, Ins_addl_subl_byte_Ptr); - - function To_Ins_addl_subl_word_Ptr is - new Unchecked_Conversion (Address, Ins_addl_subl_word_Ptr); - - begin - Ptr := A; - Prolog.Frame_Length := 0; - - if Ptr = Null_Address then - Prolog.Num_SOC_Push := 0; - Prolog.Frame_Reg := True; - return; - end if; - - if To_Ins_pushl_Ptr (Ptr).all = Ins_pushl_ebp then - Ptr := Ptr + 1 + Ins_movl_length; - Prolog.Frame_Reg := True; - else - Prolog.Frame_Reg := False; - end if; - - Pas := To_Ins_addl_subl_byte_Ptr (Ptr); - - if Pas.Op = Op_Immed - and then Pas.Op2 = Op2_subl_Immed - and then Pas.Reg = esp - then - if Pas.w = Word then - Prolog.Frame_Length := Prolog.Frame_Length + - To_Ins_addl_subl_word_Ptr (Ptr).Imm32; - Ptr := Ptr + 6; - - else - Prolog.Frame_Length := Prolog.Frame_Length + Uns32 (Pas.Imm8); - Ptr := Ptr + 3; - - -- Note: we ignore sign extension, since a sign extended - -- value that was negative would imply a ludicrous frame size. - end if; - end if; - - -- Now scan push instructions for SOC registers - - Prolog.Num_SOC_Push := 0; - - loop - Ppl := To_Ins_pushl_Ptr (Ptr); - - if Ppl.Op = Op_pushl and then Ppl.Reg in SOC then - Prolog.Num_SOC_Push := Prolog.Num_SOC_Push + 1; - Prolog.SOC_Push_Regs (Prolog.Num_SOC_Push) := Ppl.Reg; - Prolog.Frame_Length := Prolog.Frame_Length + 4; - Ptr := Ptr + 1; - - else - exit; - end if; - end loop; - - end Analyze_Prolog; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - begin - Asm ("mov %0,%%edx", Inputs => Machine_State'Asm_Input ("r", M)); - Asm ("mov %0,%%eax", Inputs => Handler_Loc'Asm_Input ("r", Handler)); - - Asm ("mov 4(%%edx),%%ebx"); -- M.Regs (ebx) - Asm ("mov 12(%%edx),%%ebp"); -- M.Regs (ebp) - Asm ("mov 16(%%edx),%%esi"); -- M.Regs (esi) - Asm ("mov 20(%%edx),%%edi"); -- M.Regs (edi) - Asm ("mov 8(%%edx),%%esp"); -- M.Regs (esp) - Asm ("jmp %*%%eax"); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - - Asm_Call_Size : constant := 2; - -- Minimum size for a call instruction under ix86. Using the minimum - -- size is safe here as the call point computed from the return point - -- will always be inside the call instruction. - - MS : constant MState_Ptr := To_MState_Ptr (M); - - begin - if MS.eip = 0 then - return To_Address (MS.eip); - else - -- When doing a call the return address is pushed to the stack. - -- We want to return the call point address, so we subtract - -- Asm_Call_Size from the return address. This value is set - -- to 5 as an asm call takes 5 bytes on x86 architectures. - - return To_Address (MS.eip - Asm_Call_Size); - end if; - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - begin - return MState'Max_Size_In_Storage_Elements; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - MS : constant MState_Ptr := To_MState_Ptr (M); - PL : Prolog_Type; - - SOC_Ptr : Uns32; - -- Pointer to stack location after last SOC push - - Rtn_Ptr : Uns32; - -- Pointer to stack location containing return address - - begin - Analyze_Prolog (Info, PL); - - -- Case of frame register, use EBP, safer than ESP - - if PL.Frame_Reg then - SOC_Ptr := MS.Regs (ebp) - PL.Frame_Length; - Rtn_Ptr := MS.Regs (ebp) + 4; - MS.Regs (ebp) := To_Uns32_Ptr (MS.Regs (ebp)).all; - - -- No frame pointer, use ESP, and hope we have it exactly right! - - else - SOC_Ptr := MS.Regs (esp); - Rtn_Ptr := SOC_Ptr + PL.Frame_Length; - end if; - - -- Get saved values of SOC registers - - for J in reverse 1 .. PL.Num_SOC_Push loop - MS.Regs (PL.SOC_Push_Regs (J)) := To_Uns32_Ptr (SOC_Ptr).all; - SOC_Ptr := SOC_Ptr + 4; - end loop; - - MS.eip := To_Uns32_Ptr (Rtn_Ptr).all; - MS.Regs (esp) := Rtn_Ptr + 4; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - N : constant Asm_Output_Operand := No_Output_Operands; - - begin - Asm ("mov %0,%%edx", N, Machine_State'Asm_Input ("r", M)); - - -- At this stage, we have the following situation (note that we - -- are assuming that the -fomit-frame-pointer switch has not been - -- used in compiling this procedure. - - -- (value of M) - -- return point - -- old ebp <------ current ebp/esp value - - -- The values of registers ebx/esi/edi are unchanged from entry - -- so they have the values we want, and %edx points to the parameter - -- value M, so we can store these values directly. - - Asm ("mov %%ebx,4(%%edx)"); -- M.Regs (ebx) - Asm ("mov %%esi,16(%%edx)"); -- M.Regs (esi) - Asm ("mov %%edi,20(%%edx)"); -- M.Regs (edi) - - -- The desired value of ebp is the old value - - Asm ("mov 0(%%ebp),%%eax"); - Asm ("mov %%eax,12(%%edx)"); -- M.Regs (ebp) - - -- The return point is the desired eip value - - Asm ("mov 4(%%ebp),%%eax"); - Asm ("mov %%eax,(%%edx)"); -- M.eip - - -- Finally, the desired %esp value is the value at the point of - -- call to this routine *before* pushing the parameter value. - - Asm ("lea 12(%%ebp),%%eax"); - Asm ("mov %%eax,8(%%edx)"); -- M.Regs (esp) - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - - begin - null; - end Set_Signal_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb index 6134879..04906e4 100644 --- a/gcc/ada/s-mastop.adb +++ b/gcc/ada/s-mastop.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Dummy version) -- -- -- --- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,8 +41,6 @@ package body System.Machine_State_Operations is pragma Warnings (Off); - use System.Exceptions; - ---------------------------- -- Allocate_Machine_State -- ---------------------------- @@ -52,15 +50,6 @@ package body System.Machine_State_Operations is return Machine_State (Null_Address); end Allocate_Machine_State; - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - begin - null; - end Enter_Handler; - ---------------- -- Fetch_Code -- ---------------- @@ -102,9 +91,7 @@ package body System.Machine_State_Operations is -- Pop_Frame -- --------------- - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) is + procedure Pop_Frame (M : Machine_State) is begin null; end Pop_Frame; @@ -118,16 +105,4 @@ package body System.Machine_State_Operations is null; end Set_Machine_State; - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - begin - null; - end Set_Signal_Machine_State; - end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads index 8ee412c..95f0da5 100644 --- a/gcc/ada/s-mastop.ads +++ b/gcc/ada/s-mastop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,7 +36,6 @@ pragma Polling (Off); -- elaboration circularities with System.Exception_Tables. with System.Storage_Elements; -with System.Exceptions; package System.Machine_State_Operations is @@ -79,65 +78,11 @@ package System.Machine_State_Operations is -- outer level, or some other frame for which no information can be -- provided. - procedure Pop_Frame - (M : Machine_State; - Info : System.Exceptions.Subprogram_Info_Type); + procedure Pop_Frame (M : Machine_State); -- This procedure pops the machine state M so that it represents the -- call point, as though the current subprogram had returned. It -- changes only the value referenced by M, and does not affect -- the current stack environment. - -- - -- The Info parameter represents information generated by the backend - -- (see description of Subprogram_Info node in sinfo.ads). This - -- information is stored as static data during compilation. The - -- caller then passes this information to Pop_Frame, which will - -- use it to determine what must be changed in the machine state - -- (e.g. which save-over-call registers must be restored, and from - -- where on the stack frame they must be restored). - -- - -- A value of No_Info for Info means either that the backend provided - -- no information for current frame, or that the current frame is an - -- other language frame for which no information exists, or that this - -- is an outer level subprogram. In any case, Pop_Frame sets the code - -- location to Null_Address when it pops past such a frame, and this - -- is taken as an indication that the exception is unhandled. - - -- Note: at the current time, Info, if present is always a copy of - -- the entry point of the procedure, as found by searching the - -- subprogram table. For the case where a procedure is indeed in - -- the table (either it is an Ada procedure, or a foreign procedure - -- which is registered using pragma Propagate_Exceptions), then the - -- entry point information will indeed be correct. It may well be - -- possible for Pop_Frame to avoid using the Info parameter (for - -- example if it consults auxiliary Dwarf tables to do its job). - -- This is desirable if it can be done, because it means that it - -- will work fine to propagate exceptions through unregistered - -- foreign procedures. What will happen is that the search in the - -- Ada subprogram table will find a junk entry. Even if this junk - -- entry has an exception table, none of them will apply to the - -- current location, so they will be ignored, and then Pop_Frame - -- will be called to pop the frame. The Info parameter for this - -- call will be junk, but if it is not used that does not matter. - -- Note that the address recorded in the traceback table is of - -- the exception location, so the traceback will be correct even - -- in this case. - - procedure Enter_Handler - (M : Machine_State; - Handler : System.Exceptions.Handler_Loc); - -- When Propagate_Handler locates an applicable exception handler, it - -- calls Enter_Handler, passing it two parameters. The first is the - -- machine state that corresponds to what is required for entry to - -- the handler, as computed by repeated Pop_Frame calls to reach the - -- handler to be entered. The second is the code location for the - -- handler itself which is the address of the label at the start of - -- the handler code. - -- - -- Note: The machine state M is likely stored on the part of the - -- stack that will be popped by the call, so care must be taken - -- not to pop the stack until the Machine_State is entirely read. - -- The value passed as Handler was obtained from elaboration of - -- an N_Handler_Loc node by the backend. function Fetch_Code (Loc : Code_Loc) return Code_Loc; -- Some architectures (notably VMS) use a descriptor to describe @@ -150,14 +95,4 @@ package System.Machine_State_Operations is -- This routine sets M from the current machine state. It is called -- when an exception is initially signalled to initialize the state. - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address); - -- This routine sets M from the machine state that corresponds to the - -- point in the code where a signal was raised. The parameter Context - -- is a pointer to a structure created by the operating system when a - -- signal is raised, and made available to the signal handler. The - -- format of this context block, and the manner in which it is made - -- available to the handler, are implementation dependent. - end System.Machine_State_Operations; diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb index a5c57de..fc337fb 100644 --- a/gcc/ada/s-traceb-mastop.adb +++ b/gcc/ada/s-traceb-mastop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-2005 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,8 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This version assumes that System.Machine_State_Operations.Pop_Frame can --- work with the Info parameter being null. +-- This version uses System.Machine_State_Operations routines with System.Machine_State_Operations; @@ -73,7 +72,7 @@ package body System.Traceback is Code := Get_Code_Loc (M); exit when Code = Null_Address or else N_Skips = Skip_Frames; - Pop_Frame (M, System.Null_Address); + Pop_Frame (M); N_Skips := N_Skips + 1; end loop; @@ -90,7 +89,7 @@ package body System.Traceback is Trace (Len) := Code; end if; - Pop_Frame (M, System.Null_Address); + Pop_Frame (M); end loop; Free_Machine_State (M); diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index 1bc271d..de69081 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -126,14 +126,6 @@ package body Switch.B is end if; end loop; - -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This - -- is for backwards compatibility with old versions and usage. - - if Debug_Flag_XX then - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - end if; - return; -- Processing for D switch diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 3277566..6c5ed1f 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -585,14 +585,6 @@ package body Switch.M is end if; end loop; - -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This - -- is for backwards compatibility with old versions and usage. - - if Debug_Flag_XX then - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - end if; - return; -- Processing for e switch diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 67a5c0d..0fd9c7f 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -67,10 +67,9 @@ package body Targparm is UAM, -- Use_Ada_Main_Program_Name VMS, -- OpenVMS ZCD, -- ZCX_By_Default - ZCG, -- GCC_ZCX_Support - ZCF); -- Front_End_ZCX_Support + ZCG); -- GCC_ZCX_Support - subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCF; + subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCG; -- Range excluding obsolete entries Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); @@ -106,7 +105,6 @@ package body Targparm is VMS_Str : aliased constant Source_Buffer := "OpenVMS"; ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support"; - ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support"; -- The following defines a set of pointers to the above strings, -- indexed by the tag values. @@ -140,8 +138,7 @@ package body Targparm is UAM_Str'Access, VMS_Str'Access, ZCD_Str'Access, - ZCG_Str'Access, - ZCF_Str'Access); + ZCG_Str'Access); ----------------------- -- Local Subprograms -- @@ -571,7 +568,6 @@ package body Targparm is when VMS => OpenVMS_On_Target := Result; when ZCD => ZCX_By_Default_On_Target := Result; when ZCG => GCC_ZCX_Support_On_Target := Result; - when ZCF => Front_End_ZCX_Support_On_Target := Result; goto Line_Loop_Continue; end case; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 7921bb2..b29f506 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -278,50 +278,24 @@ package Targparm is -- Controlling the selection of methods - -- The Front-End Longjmp/Setjmp approach is always available in - -- all implementations. If it is not the default method, then it - -- may be explicitly specified by the use of -gnatL. Note however - -- that there is a requirement that all Ada units in a partition - -- be compiled with this overriding option if it is not the default. - - -- On some, but not all, implementations of GNAT, one of the two - -- ZCX approaches (but not both) is implemented. If this is the - -- case, and ZCX is not the default mechanism, then ZCX handling - -- (front-end or back-end according to the implementation) may be - -- specified by use of the -gnatZ switch. Again, this switch must - -- be used to compile all Ada units in a partition. The use of - -- the -gnatZ switch will cause termination with a fatal error. - - -- Finally the debug option -gnatdX can be used to force the - -- compiler to operate in front-end ZCX exception mode and force - -- the front end to generate exception tables. This is only useful - -- for debugging purposes for implementations which do not provide - -- the possibility of front-end ZCX mode. The resulting object file - -- is unusable, but this debug switch may still be useful (e.g. in - -- conjunction with -gnatG) for front-end debugging purposes. + -- On most implementations, back-end zero-cost exceptions are used. + -- Otherwise, Front-End Longjmp/Setjmp approach is used. + -- Note that there is a requirement that all Ada units in a partition + -- be compiled with the same exception model. -- Control of Available Methods and Defaults - -- The following switches specify which of the two ZCX methods - -- (if any) is available in an implementation, and which method - -- is the default method. + -- The following switches specify whether ZCX is available, and + -- whether it is enabled by default. ZCX_By_Default_On_Target : Boolean := False; -- Indicates if zero cost exceptions are active by default. If this -- variable is False, then the only possible exception method is the -- front-end setjmp/longjmp approach, and this is the default. If - -- this variable is True, then one of the following two flags must - -- be True, and represents the method to be used by default. + -- this variable is True, then GCC ZCX is used. GCC_ZCX_Support_On_Target : Boolean := False; - -- Indicates that when ZCX is active, the mechanism to be used is the - -- back-end ZCX exception approach. If this variable is set to True, - -- then Front_End_ZCX_Support_On_Target must be False. - - Front_End_ZCX_Support_On_Target : Boolean := False; - -- Indicates that when ZCX is active, the mechanism to be used is the - -- front-end ZCX exception approach. If this variable is set to True, - -- then GCC_ZCX_Support_On_Target must be False. + -- Indicates that the target supports GCC Exceptions. ------------------------------------ -- Run-Time Library Configuration -- @@ -367,9 +341,6 @@ package Targparm is -- with the exception of the priority of the environment task, which -- is needed by the Ravenscar run-time. -- - -- The generation of exception tables is suppressed for front end - -- ZCX exception handling (since we assume no exception handling). - -- -- The calls to __gnat_initialize and __gnat_finalize are omitted -- -- All finalization and initialization (controlled types) is omitted diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index c96971a..39f3b71 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -220,11 +220,6 @@ begin Write_Switch_Char ("l"); Write_Line ("Output full source listing with embedded error messages"); - -- Line for -gnatL switch - - Write_Switch_Char ("L"); - Write_Line ("Use longjmp/setjmp for exception handling"); - -- Line for -gnatm switch Write_Switch_Char ("mnnn"); @@ -465,11 +460,6 @@ begin Write_Switch_Char ("z"); Write_Line ("Distribution stub generation (r/c for receiver/caller stubs)"); - -- Line for -gnatZ switch - - Write_Switch_Char ("Z"); - Write_Line ("Use zero cost exception handling"); - -- Line for -gnat83 switch Write_Switch_Char ("83"); -- 2.7.4