diff options
author | bosch <bosch@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-12-20 06:22:43 +0000 |
---|---|---|
committer | bosch <bosch@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-12-20 06:22:43 +0000 |
commit | 4c2698ed6802669784e51f97b390e7f836457407 (patch) | |
tree | 0fb5f707e1f7868b6ca9dde005027d1520338a01 /gcc/ada | |
parent | 3affb0ca724651a96e35f3c823e64d123c0cac7d (diff) | |
download | gcc-4c2698ed6802669784e51f97b390e7f836457407.tar.gz |
* bindgen.adb: Minor reformatting
* cstand.adb: Minor reformatting
* fmap.adb: Minor reformatting
Change name from Add for Add_To_File_Map (Add is much too generic)
Change Path_Name_Of to Mapped_Path_Name
Change File_Name_Of to Mapped_File_Name
Fix copyright dates in header
* fmap.ads:
Change name from Add for Add_To_File_Map (Add is much too generic)
Change Path_Name_Of to Mapped_Path_Name
Change File_Name_Of to Mapped_File_Name
Fix copyright dates in header
* fname-uf.adb: Minor reformatting. New names of stuff in Fmap.
Add use clause for Fmap.
* make.adb: Minor reformatting
* osint.adb: Minor reformatting. Change of names in Fmap.
Add use clause for Fmap.
* prj-env.adb: Minor reformatting
* prj-env.ads: Minor reformatting
* switch.adb: Minor reformatting. Do proper raise of Bad_Switch if
error found (there were odd exceptions to this general rule in
-gnatec/-gnatem processing)
* raise.c (__gnat_eh_personality): Exception handling personality
routine for Ada. Still in rough state, inspired from the C++ version
and still containing a bunch of debugging artifacts.
(parse_lsda_header, get_ttype_entry): Local (static) helpers, also
inspired from the C++ library.
* raise.c (eh_personality): Add comments. Part of work for the GCC 3
exception handling integration.
* Makefile.in: Remove use of 5smastop.adb which is obsolete.
(HIE_SOURCES): Add s-secsta.ad{s,b}.
(HIE_OBJS): Add s-fat*.o
(RAVEN_SOURCES): Remove files that are no longer required. Add
interrupt handling files.
(RAVEN_MOD): Removed, no longer needed.
* a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always
Add 2001 to copyright date
* g-regpat.adb: Change pragma Inline_Always to Inline. There is no
need to force universal inlining for these cases.
* s-taprob.adb: Minor clean ups so that this unit can be used in
Ravenscar HI.
* exp_ch7.adb: Allow use of secondary stack in HI mode.
Disallow it when pragma Restrictions (No_Secondary_Stack) is specified.
* prj-tree.ads (Project_Node_Record): Add comments for components
Pkg_Id and Case_Insensitive.
* g-socket.adb: Minor reformatting. Found while reading code.
* prj-tree.ads: Minor reformatting
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@48195 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 83 | ||||
-rw-r--r-- | gcc/ada/Makefile.in | 41 | ||||
-rw-r--r-- | gcc/ada/a-ngelfu.adb | 10 | ||||
-rw-r--r-- | gcc/ada/bindgen.adb | 17 | ||||
-rw-r--r-- | gcc/ada/cstand.adb | 15 | ||||
-rw-r--r-- | gcc/ada/exp_ch7.adb | 8 | ||||
-rw-r--r-- | gcc/ada/fmap.adb | 81 | ||||
-rw-r--r-- | gcc/ada/fmap.ads | 10 | ||||
-rw-r--r-- | gcc/ada/fname-uf.adb | 11 | ||||
-rw-r--r-- | gcc/ada/g-regpat.adb | 21 | ||||
-rw-r--r-- | gcc/ada/g-socket.adb | 20 | ||||
-rw-r--r-- | gcc/ada/make.adb | 1 | ||||
-rw-r--r-- | gcc/ada/osint.adb | 8 | ||||
-rw-r--r-- | gcc/ada/prj-env.adb | 24 | ||||
-rw-r--r-- | gcc/ada/prj-env.ads | 5 | ||||
-rw-r--r-- | gcc/ada/prj-tree.ads | 67 | ||||
-rw-r--r-- | gcc/ada/raise.c | 526 | ||||
-rw-r--r-- | gcc/ada/s-taprob.adb | 10 | ||||
-rw-r--r-- | gcc/ada/switch.adb | 10 |
19 files changed, 789 insertions, 179 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3271ffc841e..6b0289bbb3e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,86 @@ +2001-12-19 Robert Dewar <dewar@gnat.com> + + * bindgen.adb: Minor reformatting + + * cstand.adb: Minor reformatting + + * fmap.adb: Minor reformatting + Change name from Add for Add_To_File_Map (Add is much too generic) + Change Path_Name_Of to Mapped_Path_Name + Change File_Name_Of to Mapped_File_Name + Fix copyright dates in header + + * fmap.ads: + Change name from Add for Add_To_File_Map (Add is much too generic) + Change Path_Name_Of to Mapped_Path_Name + Change File_Name_Of to Mapped_File_Name + Fix copyright dates in header + + * fname-uf.adb: Minor reformatting. New names of stuff in Fmap. + Add use clause for Fmap. + + * make.adb: Minor reformatting + + * osint.adb: Minor reformatting. Change of names in Fmap. + Add use clause for Fmap. + + * prj-env.adb: Minor reformatting + + * prj-env.ads: Minor reformatting + + * switch.adb: Minor reformatting. Do proper raise of Bad_Switch if + error found (there were odd exceptions to this general rule in + -gnatec/-gnatem processing) + +2001-12-19 Olivier Hainque <hainque@gnat.com> + + * raise.c (__gnat_eh_personality): Exception handling personality + routine for Ada. Still in rough state, inspired from the C++ version + and still containing a bunch of debugging artifacts. + (parse_lsda_header, get_ttype_entry): Local (static) helpers, also + inspired from the C++ library. + + * raise.c (eh_personality): Add comments. Part of work for the GCC 3 + exception handling integration. + +2001-12-19 Arnaud Charlet <charlet@gnat.com> + + * Makefile.in: Remove use of 5smastop.adb which is obsolete. + (HIE_SOURCES): Add s-secsta.ad{s,b}. + (HIE_OBJS): Add s-fat*.o + (RAVEN_SOURCES): Remove files that are no longer required. Add + interrupt handling files. + (RAVEN_MOD): Removed, no longer needed. + +2001-12-19 Robert Dewar <dewar@gnat.com> + + * a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always + Add 2001 to copyright date + + * g-regpat.adb: Change pragma Inline_Always to Inline. There is no + need to force universal inlining for these cases. + +2001-12-19 Arnaud Charlet <charlet@gnat.com> + + * s-taprob.adb: Minor clean ups so that this unit can be used in + Ravenscar HI. + + * exp_ch7.adb: Allow use of secondary stack in HI mode. + Disallow it when pragma Restrictions (No_Secondary_Stack) is specified. + +2001-12-19 Vincent Celier <celier@gnat.com> + + * prj-tree.ads (Project_Node_Record): Add comments for components + Pkg_Id and Case_Insensitive. + +2001-12-19 Pascal Obry <obry@gnat.com> + + * g-socket.adb: Minor reformatting. Found while reading code. + +2001-12-19 Robert Dewar <dewar@gnat.com> + + * prj-tree.ads: Minor reformatting + 2001-12-20 Joseph S. Myers <jsm28@cam.ac.uk> * config-lang.in (diff_excludes): Remove. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 0bd940bc098..84f1b0f305e 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1060,7 +1060,6 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) a-intnam.ads<4sintnam.ads \ s-inmaop.adb<7sinmaop.adb \ s-intman.adb<5sintman.adb \ - s-mastop.adb<5smastop.adb \ s-osinte.adb<5sosinte.adb \ s-osinte.ads<5sosinte.ads \ s-osprim.adb<5posprim.adb \ @@ -1086,7 +1085,6 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) a-intnam.ads<4sintnam.ads \ s-inmaop.adb<7sinmaop.adb \ s-intman.adb<5sintman.adb \ - s-mastop.adb<5smastop.adb \ s-osinte.adb<7sosinte.adb \ s-osinte.ads<5tosinte.ads \ s-osprim.adb<5posprim.adb \ @@ -1105,7 +1103,6 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) a-intnam.ads<4sintnam.ads \ s-inmaop.adb<7sinmaop.adb \ s-intman.adb<7sintman.adb \ - s-mastop.adb<5smastop.adb \ s-osinte.adb<5iosinte.adb \ s-osinte.ads<54osinte.ads \ s-osprim.adb<5posprim.adb \ @@ -1909,6 +1906,8 @@ HIE_SOURCES = \ s-fatlfl.ads \ s-fatllf.ads \ s-fatsfl.ads \ + s-secsta.ads \ + s-secsta.adb \ a-tags.ads \ a-tags.adb $(EXTRA_HIE_SOURCES) @@ -1923,23 +1922,19 @@ HIE_OBJS = \ s-stoele.o \ s-maccod.o \ s-unstyp.o \ + s-fatflt.o \ + s-fatlfl.o \ + s-fatllf.o \ + s-secsta.o \ a-tags.o $(EXTRA_HIE_OBJS) # Files which are needed in ravenscar mode RAVEN_SOURCES = \ $(HIE_SOURCES) \ - s-arit64.ads \ - s-arit64.adb \ s-parame.ads \ s-parame.adb \ g-except.ads \ - s-stalib.ads \ - s-stalib.adb \ - s-soflin.ads \ - s-soflin.adb \ - s-secsta.ads \ - s-secsta.adb \ s-osinte.ads \ s-osinte.adb \ s-tasinf.ads \ @@ -1948,9 +1943,12 @@ RAVEN_SOURCES = \ s-taprop.ads \ s-taprop.adb \ s-taskin.ads \ + s-taskin.adb \ s-interr.ads \ s-interr.adb \ - s-taskin.adb \ + a-interr.ads \ + a-interr.adb \ + a-intnam.ads \ a-reatim.ads \ a-reatim.adb \ a-retide.ads \ @@ -1963,33 +1961,24 @@ RAVEN_SOURCES = \ s-tarest.ads \ s-tarest.adb $(EXTRA_RAVEN_SOURCES) -# Files that need to be preprocessed before inclusion in a ravenscar run time - -RAVEN_MOD = \ - s-tposen.adb \ - s-tarest.adb - # Objects to generate for the ravenscar run time RAVEN_OBJS = \ $(HIE_OBJS) \ - g-except.o \ - s-stalib.o \ - s-arit64.o \ s-parame.o \ - s-soflin.o \ - s-secsta.o \ - s-tasinf.o \ + g-except.o \ s-osinte.o \ + s-tasinf.o \ s-taspri.o \ s-taprop.o \ s-taskin.o \ - s-taprob.o \ - s-tposen.o \ s-interr.o \ a-interr.o \ + a-intnam.o \ a-reatim.o \ a-retide.o \ + s-taprob.o \ + s-tposen.o \ s-tasres.o \ s-tarest.o $(EXTRA_RAVEN_OBJS) diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index 2a7201e874f..d22951c447e 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.44 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2001, 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- -- @@ -52,11 +52,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; Half_Log_Two : constant := Log_Two / 2; - subtype T is Float_Type'Base; subtype Double is Aux.Double; - Two_Pi : constant T := 2.0 * Pi; Half_Pi : constant T := Pi / 2.0; Fourth_Pi : constant T := Pi / 4.0; @@ -68,7 +66,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two; Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); - DEpsilon : constant Double := Double (Epsilon); DIEpsilon : constant Double := Double (IEpsilon); @@ -558,7 +555,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is -- Just reuse the code for Sin. The potential small -- loss of speed is negligible with proper (front-end) inlining. - -- ??? Add pragma Inline_Always in spec when this is supported return -Sin (abs X - Cycle * 0.25, Cycle); end Cos; @@ -716,7 +712,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0; R := 0.5 + P / (Q - P); - R := Float_Type'Base'Scaling (R, Integer (XN) + 1); -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows @@ -732,7 +727,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is end Exp_Strict; - ---------------- -- Local_Atan -- ---------------- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index b1f19af6e13..55ec4324ab8 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -343,16 +343,16 @@ package body Bindgen is Write_Statement_Buffer; - -- Normal case (no pragma No_Run_Time). The global values are + -- Normal case (not No_Run_Time mode). The global values are -- assigned using the runtime routine Set_Globals (we have to use -- the routine call, rather than define the globals in the binder -- file to deal with cross-library calls in some systems. if No_Run_Time_Specified then - -- Case of pragma No_Run_Time present. The only global variable - -- that might be needed (by the Ravenscar profile) is - -- the environment task's priority. Also no exception tables are - -- needed. + + -- Case of No_Run_Time mode. The only global variable that might + -- be needed (by the Ravenscar profile) is the priority of the + -- environment. Also no exception tables are needed. if Main_Priority /= No_Main_Priority then WBI (" Main_Priority : Integer;"); @@ -513,8 +513,9 @@ package body Bindgen is Write_Statement_Buffer; if No_Run_Time_Specified then - -- Case where No_Run_Time pragma is present. - -- Set __gl_main_priority if needed for the Ravenscar profile. + + -- Case of No_Run_Time mode. Set __gl_main_priority if needed + -- for the Ravenscar profile. if Main_Priority /= No_Main_Priority then Set_String (" extern int __gl_main_priority = "); @@ -524,7 +525,7 @@ package body Bindgen is end if; else - -- Code for normal case (no pragma No_Run_Time in use) + -- Code for normal case (not in No_Run_Time mode) Gen_Exception_Table_C; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 1527ce10cf8..75378b579f7 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1001,23 +1001,28 @@ package body CStand is Set_Size_Known_At_Compile_Time (Universal_Fixed); - -- Create type declaration for Duration, using a 64-bit size. - -- Delta is 1 nanosecond. - -- Except on 32 bits machine in No_Run_Time mode, in which case Duration - -- is a 32 bits value whose delta is 10E-4 seconds. + -- Create type declaration for Duration, using a 64-bit size. The + -- delta value depends on the mode we are running in: + + -- Normal mode or No_Run_Time mode when word size is 64 bits: + -- 10**(-9) seconds, size is 64 bits + + -- No_Run_Time mode when word size is 32 bits: + -- 10**(-4) seconds, oize is 32 bits Build_Duration : declare Dlo : Uint; Dhi : Uint; Delta_Val : Ureal; Use_32_Bits : constant Boolean := - No_Run_Time and then System_Word_Size = 32; + No_Run_Time and then System_Word_Size = 32; begin if Use_32_Bits then Dlo := Intval (Type_Low_Bound (Standard_Integer_32)); Dhi := Intval (Type_High_Bound (Standard_Integer_32)); Delta_Val := UR_From_Components (Uint_1, Uint_4, 10); + else Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); Dhi := Intval (Type_High_Bound (Standard_Integer_64)); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 825a44d336a..0e13169789e 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -601,7 +601,7 @@ package body Exp_Ch7 is if Sec_Stk then Set_Uses_Sec_Stack (Current_Scope); - Disallow_In_No_Run_Time_Mode (N); + Check_Restriction (No_Secondary_Stack, N); end if; Set_Etype (Current_Scope, Standard_Void_Type); @@ -2449,7 +2449,7 @@ package body Exp_Ch7 is if not Requires_Transient_Scope (Etype (S)) then if not Functions_Return_By_DSP_On_Target then Set_Uses_Sec_Stack (S, True); - Disallow_In_No_Run_Time_Mode (Action); + Check_Restriction (No_Secondary_Stack, Action); end if; end if; @@ -2470,7 +2470,7 @@ package body Exp_Ch7 is then if not Functions_Return_By_DSP_On_Target then Set_Uses_Sec_Stack (S, True); - Disallow_In_No_Run_Time_Mode (Action); + Check_Restriction (No_Secondary_Stack, Action); end if; Set_Uses_Sec_Stack (Current_Scope, False); @@ -2703,7 +2703,7 @@ package body Exp_Ch7 is null; else Set_Uses_Sec_Stack (S); - Disallow_In_No_Run_Time_Mode (N); + Check_Restriction (No_Secondary_Stack, N); end if; end if; end Wrap_Transient_Declaration; diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 89b3fd810f7..54409cd9e35 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision$ +-- $Revision: 1.1 $ -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 2001, 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- -- @@ -26,14 +26,15 @@ -- -- ------------------------------------------------------------------------------ -with GNAT.HTable; -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; with Table; with Unchecked_Conversion; +with GNAT.HTable; + package body Fmap is subtype Big_String is String (Positive); @@ -63,6 +64,7 @@ package body Fmap is type Header_Num is range 0 .. 1_000; function Hash (F : Unit_Name_Type) return Header_Num; + -- Function used to compute hash of unit name No_Entry : constant Int := -1; -- Signals no entry in following table @@ -87,14 +89,15 @@ package body Fmap is -- Hash table to map file names to path names. Used in conjunction with -- table Path_Mapping above. - --------- - -- Add -- - --------- + --------------------- + -- Add_To_File_Map -- + --------------------- - procedure Add + procedure Add_To_File_Map (Unit_Name : Unit_Name_Type; File_Name : File_Name_Type; - Path_Name : File_Name_Type) is + Path_Name : File_Name_Type) + is begin File_Mapping.Increment_Last; Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); @@ -102,23 +105,7 @@ package body Fmap is Path_Mapping.Increment_Last; File_Hash_Table.Set (File_Name, Path_Mapping.Last); Path_Mapping.Table (Path_Mapping.Last) := Path_Name; - end Add; - - ------------------ - -- File_Name_Of -- - ------------------ - - function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type is - The_Index : constant Int := Unit_Hash_Table.Get (Unit); - begin - if The_Index = No_Entry then - return No_File; - - else - return File_Mapping.Table (The_Index); - end if; - - end File_Name_Of; + end Add_To_File_Map; ---------- -- Hash -- @@ -174,10 +161,12 @@ package body Fmap is procedure Get_Line is use ASCII; + begin Deb := Fin + 1; -- If not at the end of file, skip the end of line + while Deb < SP'Last and then (SP (Deb) = CR or else SP (Deb) = LF @@ -213,7 +202,7 @@ package body Fmap is Write_Line (""" is truncated"); end Report_Truncated; - -- start of procedure Initialize + -- Start of procedure Initialize begin Name_Len := File_Name'Length; @@ -230,7 +219,6 @@ package body Fmap is SP := BS (1 .. Natural (Hi))'Unrestricted_Access; loop - -- Get the unit name Get_Line; @@ -303,30 +291,41 @@ package body Fmap is -- Add the mappings for this unit name - Add (Uname, Fname, Pname); - + Add_To_File_Map (Uname, Fname, Pname); end loop; - end if; - end Initialize; - ------------------ - -- Path_Name_Of -- - ------------------ + ---------------------- + -- Mapped_File_Name -- + ---------------------- + + function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is + The_Index : constant Int := Unit_Hash_Table.Get (Unit); + + begin + if The_Index = No_Entry then + return No_File; + else + return File_Mapping.Table (The_Index); + end if; + end Mapped_File_Name; + + ---------------------- + -- Mapped_Path_Name -- + ---------------------- - function Path_Name_Of (File : File_Name_Type) return File_Name_Type is + function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is Index : Int := No_Entry; + begin Index := File_Hash_Table.Get (File); if Index = No_Entry then return No_File; - else return Path_Mapping.Table (Index); end if; - - end Path_Name_Of; + end Mapped_Path_Name; end Fmap; diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads index ac9c0e5103b..57ea0165165 100644 --- a/gcc/ada/fmap.ads +++ b/gcc/ada/fmap.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision$ +-- $Revision: 1.1 $ -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 2001, 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- -- @@ -38,15 +38,15 @@ package Fmap is -- If the mapping file is incorrect (non existent file, truncated file, -- duplicate entries), output a warning and do not initialize the mappings. - function Path_Name_Of (File : File_Name_Type) return File_Name_Type; + function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type; -- Return the path name mapped to the file name File. -- Return No_File if File is not mapped. - function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type; + function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type; -- Return the file name mapped to the unit name Unit. -- Return No_File if Unit is not mapped. - procedure Add + procedure Add_To_File_Map (Unit_Name : Unit_Name_Type; File_Name : File_Name_Type; Path_Name : File_Name_Type); diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 3572d1a6f7a..f2b549c3ac6 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -28,7 +28,7 @@ with Alloc; with Debug; use Debug; -with Fmap; +with Fmap; use Fmap; with Krunch; with Namet; use Namet; with Opt; use Opt; @@ -140,6 +140,7 @@ package body Fname.UF is Pname : File_Name_Type := No_File; Fname : File_Name_Type := No_File; + -- Path name and File name for mapping begin -- Null or error name means that some previous error occurred @@ -149,12 +150,12 @@ package body Fname.UF is raise Unrecoverable_Error; end if; - -- Look into the mapping from unit names to file names + -- Look in the map from unit names to file names - Fname := Fmap.File_Name_Of (Uname); + Fname := Mapped_File_Name (Uname); -- If the unit name is already mapped, return the corresponding - -- file name. + -- file name from the map. if Fname /= No_File then return Fname; @@ -394,7 +395,7 @@ package body Fname.UF is -- Add to mapping, so that we don't do another -- path search in Find_File for this file name - Fmap.Add (Get_File_Name.Uname, Fnam, Pname); + Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); return Fnam; -- This entry does not match after all, because this is diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb index ab1b69c79d0..da4748c30ea 100644 --- a/gcc/ada/g-regpat.adb +++ b/gcc/ada/g-regpat.adb @@ -245,9 +245,9 @@ package body GNAT.Regpat is procedure Reset_Class (Bitmap : in out Character_Class); -- Clear all the entries in the class Bitmap. - pragma Inline_Always (Set_In_Class); - pragma Inline_Always (Get_From_Class); - pragma Inline_Always (Reset_Class); + pragma Inline (Set_In_Class); + pragma Inline (Get_From_Class); + pragma Inline (Reset_Class); ----------------------- -- Local Subprograms -- @@ -512,9 +512,9 @@ package body GNAT.Regpat is -- Parse a posic character class, like [:alpha:] or [:^alpha:]. -- The called is suppoed to absorbe the opening [. - pragma Inline_Always (Is_Mult); - pragma Inline_Always (Emit_Natural); - pragma Inline_Always (Parse_Character_Class); -- since used only once + pragma Inline (Is_Mult); + pragma Inline (Emit_Natural); + pragma Inline (Parse_Character_Class); -- since used only once --------------- -- Case_Emit -- @@ -2401,12 +2401,13 @@ package body GNAT.Regpat is return Boolean; -- Return True it the simple operator (possibly non-greedy) matches - pragma Inline_Always (Index); - pragma Inline_Always (Repeat); + pragma Inline (Index); + pragma Inline (Repeat); -- These are two complex functions, but used only once. - pragma Inline_Always (Match_Whilem); - pragma Inline_Always (Match_Simple_Operator); + + pragma Inline (Match_Whilem); + pragma Inline (Match_Simple_Operator); ----------- -- Index -- diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index b58a0dc20c0..3b794b72930 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.21 $ +-- $Revision$ -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- @@ -166,12 +166,11 @@ package body GNAT.Sockets is -- Types needed for Datagram_Socket_Stream_Type - type Datagram_Socket_Stream_Type is new Root_Stream_Type with - record - Socket : Socket_Type; - To : Sock_Addr_Type; - From : Sock_Addr_Type; - end record; + type Datagram_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + To : Sock_Addr_Type; + From : Sock_Addr_Type; + end record; type Datagram_Socket_Stream_Access is access all Datagram_Socket_Stream_Type; @@ -187,10 +186,9 @@ package body GNAT.Sockets is -- Types needed for Stream_Socket_Stream_Type - type Stream_Socket_Stream_Type is new Root_Stream_Type with - record - Socket : Socket_Type; - end record; + type Stream_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + end record; type Stream_Socket_Stream_Access is access all Stream_Socket_Stream_Type; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 7e0fd58cfb5..6b61456aa33 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -3501,7 +3501,6 @@ package body Make is begin Delete_File (Name => Mapping_File_Name, Success => Success); end; - end if; Exit_Program (E_Success); diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 1856f16d6c9..27857d02f06 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -26,7 +26,7 @@ -- -- ------------------------------------------------------------------------------ -with Fmap; +with Fmap; use Fmap; with Hostparm; with Namet; use Namet; with Opt; use Opt; @@ -996,16 +996,16 @@ package body Osint is -- directory where the user said it was. elsif Look_In_Primary_Directory_For_Current_Main - and then Current_Main = N then + and then Current_Main = N + then return Locate_File (N, T, Primary_Directory, File_Name); -- Otherwise do standard search for source file else - -- Check the mapping of this file name - File := Fmap.Path_Name_Of (N); + File := Mapped_Path_Name (N); -- If the file name is mapped to a path name, return the -- corresponding path name diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index e52165d167a..fd5109bb05c 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -804,6 +804,10 @@ package body Prj.Env is -- Put the mapping of the spec or body contained in Data in the file -- (3 lines). + --------- + -- Put -- + --------- + procedure Put (S : String) is Last : Natural; @@ -813,9 +817,12 @@ package body Prj.Env is if Last /= S'Length then Osint.Fail ("Disk full"); end if; - end Put; + -------------- + -- Put_Data -- + -------------- + procedure Put_Data (Spec : Boolean) is begin Put (Get_Name_String (The_Unit_Data.Name)); @@ -833,6 +840,8 @@ package body Prj.Env is Put (S => (1 => ASCII.LF)); end Put_Data; + -- Start of processing for Create_Mapping_File + begin GNAT.OS_Lib.Create_Temp_File (File, Name => Name); @@ -938,7 +947,7 @@ package body Prj.Env is for Current in reverse Units.First .. Units.Last loop Unit := Units.Table (Current); - -- If it is a unit of the same project + -- Case of unit of the same project if Unit.File_Names (Body_Part).Project = Project then declare @@ -946,7 +955,7 @@ package body Prj.Env is Unit.File_Names (Body_Part).Name; begin - -- If there is a body + -- Case of a body present if Current_Name /= No_Name then if Current_Verbosity = High then @@ -987,7 +996,7 @@ package body Prj.Env is end; end if; - -- If it is a unit of the same project + -- Case of a unit of the same project if Units.Table (Current).File_Names (Specification).Project = Project @@ -997,7 +1006,7 @@ package body Prj.Env is Unit.File_Names (Specification).Name; begin - -- If there is a spec + -- Case of spec present if Current_Name /= No_Name then if Current_Verbosity = High then @@ -1007,8 +1016,7 @@ package body Prj.Env is Write_Eol; end if; - -- If it has the same name as the original name, - -- return the original name + -- If name same as the original name, return original name if Unit.Name = The_Original_Name or else Current_Name = The_Original_Name @@ -1020,7 +1028,7 @@ package body Prj.Env is return Get_Name_String (Current_Name); -- If it has the same name as the extended spec name, - -- return the extended spec name + -- return the extended spec name. elsif Current_Name = The_Spec_Name then if Current_Verbosity = High then diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index f418dc34cec..36687b46b1e 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -40,9 +40,8 @@ package Prj.Env is -- Output the list of sources, after Project files have been scanned procedure Create_Mapping_File (Name : in out Temp_File_Name); - -- Create a temporary mapping file. - -- For each unit, put the mapping of its spec and or body to its - -- file name and path name in this file. + -- Create a temporary mapping file. For each unit, put the mapping of + -- its spec and or body to its file name and path name in this file. procedure Create_Config_Pragmas_File (For_Project : Project_Id; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index c5526b8527e..6a7ae30304d 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -38,27 +38,30 @@ with Table; package Prj.Tree is Project_Nodes_Initial : constant := 1_000; - -- Initial number of nodes in table Tree_Private_Part.Project_Nodes Project_Nodes_Increment : constant := 100; + -- Allocation parameters for initializing and extending number + -- of nodes in table Tree_Private_Part.Project_Nodes Project_Node_Low_Bound : constant := 0; - Project_Node_High_Bound : constant := 099_999_999; -- In practice, infinite + Project_Node_High_Bound : constant := 099_999_999; + -- Range of values for project node id's (in practice infinite) type Project_Node_Id is range Project_Node_Low_Bound .. Project_Node_High_Bound; -- The index of table Tree_Private_Part.Project_Nodes - Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound; + Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound; -- Designates no node in table Project_Nodes + First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound; - subtype Variable_Node_Id is Project_Node_Id; - -- Used to designate a node whose expected kind is + subtype Variable_Node_Id is Project_Node_Id; + -- Used to designate a node whose expected kind is one of -- N_Typed_Variable_Declaration, N_Variable_Declaration or -- N_Variable_Reference. + subtype Package_Declaration_Id is Project_Node_Id; - -- Used to designate a node whose expected kind is - -- N_Project_Declaration. + -- Used to designate a node whose expected kind is N_Proect_Declaration type Project_Node_Kind is (N_Project, @@ -90,7 +93,7 @@ package Prj.Tree is function Default_Project_Node (Of_Kind : Project_Node_Kind; And_Expr_Kind : Variable_Kind := Undefined) - return Project_Node_Id; + return Project_Node_Id; -- Returns a Project_Node_Record with the specified Kind and -- Expr_Kind; all the other components have default nil values. @@ -121,7 +124,7 @@ package Prj.Tree is function First_Variable_Of (Node : Project_Node_Id) - return Variable_Node_Id; + return Variable_Node_Id; -- Only valid for N_Project or N_Package_Declaration nodes function First_Package_Of @@ -499,44 +502,52 @@ package Prj.Tree is type Project_Node_Record is record - Kind : Project_Node_Kind; + Kind : Project_Node_Kind; - Location : Source_Ptr := No_Location; + Location : Source_Ptr := No_Location; - Directory : Name_Id := No_Name; + Directory : Name_Id := No_Name; -- Only for N_Project - Expr_Kind : Variable_Kind := Undefined; + Expr_Kind : Variable_Kind := Undefined; -- See below for what Project_Node_Kind it is used - Variables : Variable_Node_Id := Empty_Node; + Variables : Variable_Node_Id := Empty_Node; -- First variable in a project or a package - Packages : Package_Declaration_Id := Empty_Node; + Packages : Package_Declaration_Id := Empty_Node; -- First package declaration in a project - Pkg_Id : Package_Node_Id := Empty_Package; - -- Only use in Package_Declaration - - Name : Name_Id := No_Name; + Pkg_Id : Package_Node_Id := Empty_Package; + -- Only used for N_Package_Declaration + -- The component Pkg_Id is an entry into the table Package_Attributes + -- (in Prj.Attr). It is used to indicate all the attributes of the + -- package with their characteristics. + -- + -- The tables Prj.Attr.Attributes and Prj.Attr.Package_Attributes + -- are built once and for all through a call (from Prj.Initialize) + -- to procedure Prj.Attr.Initialize. It is never modified after that. + + Name : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used - Path_Name : Name_Id := No_Name; + Path_Name : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used - Value : String_Id := No_String; + Value : String_Id := No_String; -- See below for what Project_Node_Kind it is used - Field1 : Project_Node_Id := Empty_Node; + Field1 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind - Field2 : Project_Node_Id := Empty_Node; + Field2 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind - Field3 : Project_Node_Id := Empty_Node; + Field3 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind - Case_Insensitive : Boolean := False; + Case_Insensitive : Boolean := False; + -- Significant only for N_Attribute_Declaration -- Indicates, for an associative array attribute, that the -- index is case insensitive. @@ -726,10 +737,12 @@ package Prj.Tree is -- from project files. type Project_Name_And_Node is record - Name : Name_Id; + Name : Name_Id; -- Name of the project - Node : Project_Node_Id; + + Node : Project_Node_Id; -- Node of the project in table Project_Nodes + Modified : Boolean; -- True when the project is being modified by another project end record; diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index 43d630795a8..2d48db80693 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * @@ -84,3 +84,527 @@ __gnat_unhandled_terminate () __gnat_os_exit (1); #endif } + +/* Below is the eh personality routine for Ada to be called when the GCC + mechanism is used. + + ??? It is currently inspired from the one for C++, needs cleanups and + additional comments. It also contains a big bunch of debugging code that + we shall get rid of at some point. */ + +#ifdef IN_RTS /* For eh personality routine */ + +/* ??? Does it make any sense to leave this for the compiler ? */ + +#include "dwarf2.h" +#include "unwind.h" +#include "unwind-dw2-fde.h" +#include "unwind-pe.h" + +/* First define a set of useful structures and helper routines. */ + +typedef struct _Unwind_Context _Unwind_Context; + +struct lsda_header_info +{ + _Unwind_Ptr Start; + _Unwind_Ptr LPStart; + _Unwind_Ptr ttype_base; + const unsigned char *TType; + const unsigned char *action_table; + unsigned char ttype_encoding; + unsigned char call_site_encoding; +}; + +typedef struct lsda_header_info lsda_header_info; + +typedef enum {false = 0, true = 1} bool; + +static const unsigned char * +parse_lsda_header (_Unwind_Context *context, const unsigned char *p, + lsda_header_info *info) +{ + _Unwind_Ptr tmp; + unsigned char lpstart_encoding; + + info->Start = (context ? _Unwind_GetRegionStart (context) : 0); + + /* Find @LPStart, the base to which landing pad offsets are relative. */ + lpstart_encoding = *p++; + if (lpstart_encoding != DW_EH_PE_omit) + p = read_encoded_value (context, lpstart_encoding, p, &info->LPStart); + else + info->LPStart = info->Start; + + /* Find @TType, the base of the handler and exception spec type data. */ + info->ttype_encoding = *p++; + if (info->ttype_encoding != DW_EH_PE_omit) + { + p = read_uleb128 (p, &tmp); + info->TType = p + tmp; + } + else + info->TType = 0; + + /* The encoding and length of the call-site table; the action table + immediately follows. */ + info->call_site_encoding = *p++; + p = read_uleb128 (p, &tmp); + info->action_table = p + tmp; + + return p; +} + + +static const _Unwind_Ptr +get_ttype_entry (_Unwind_Context *context, lsda_header_info *info, long i) +{ + _Unwind_Ptr ptr; + + i *= size_of_encoded_value (info->ttype_encoding); + read_encoded_value (context, info->ttype_encoding, info->TType - i, &ptr); + + return ptr; +} + +/* This is the structure of exception objects as built by the GNAT runtime + library (a-except.adb). The layouts should exactly match, and the "common" + header is mandated by the exception handling ABI. */ + +struct _GNAT_Exception { + struct _Unwind_Exception common; + + _Unwind_Ptr id; + + char handled_by_others; + char has_cleanup; + char select_cleanups; +}; + + +/* The two constants below are specific ttype identifiers for special + exception ids. Their value is currently hardcoded at the gigi level + (see N_Exception_Handler). */ + +#define GNAT_OTHERS_ID ((_Unwind_Ptr) 0x0) +#define GNAT_ALL_OTHERS_ID ((_Unwind_Ptr) 0x1) + + +/* The DB stuff below is there for debugging purposes only. */ + +#define DB_PHASES 0x1 +#define DB_SEARCH 0x2 +#define DB_ECLASS 0x4 +#define DB_MATCH 0x8 +#define DB_SAW 0x10 +#define DB_FOUND 0x20 +#define DB_INSTALL 0x40 +#define DB_CALLS 0x80 + +#define AEHP_DB_SPECS \ +(DB_PHASES | DB_SEARCH | DB_SAW | DB_FOUND | DB_INSTALL | DB_CALLS | DB_MATCH) + +#undef AEHP_DB_SPECS + +#ifdef AEHP_DB_SPECS +static int db_specs = AEHP_DB_SPECS; +#else +static int db_specs = 0; +#endif + +#define START_DB(what) do { if (what & db_specs) { +#define END_DB(what) } \ + } while (0); + +/* The "action" stuff below if also there for debugging purposes only. */ + +typedef struct { + _Unwind_Action action; + char * description; +} action_description_t; + +action_description_t action_descriptions [] = { + { _UA_SEARCH_PHASE, "SEARCH_PHASE" }, + { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" }, + { _UA_HANDLER_FRAME, "HANDLER_FRAME" }, + { _UA_FORCE_UNWIND, "FORCE_UNWIND" }, + { -1, (char *)0 } +}; + +static void +decode_actions (actions) + _Unwind_Action actions; +{ + int i; + + action_description_t * a = action_descriptions; + + printf ("\n"); + while (a->description != (char *)0) + { + if (actions & a->action) + { + printf ("%s ", a->description); + } + + a ++; + } + + printf (" : "); +} + +/* The following is defined from a-except.adb. It's purpose is to enable + automatic backtraces upon exception raise, as provided through the + GNAT.Traceback facilities. */ +extern void +__gnat_notify_handled_exception (void * handler, bool others, bool db_notify); + +/* Below is the eh personality routine per se. */ + +_Unwind_Reason_Code +__gnat_eh_personality (int version, + _Unwind_Action actions, + _Unwind_Exception_Class exception_class, + struct _Unwind_Exception *ue_header, + struct _Unwind_Context *context) +{ + enum found_handler_type + { + found_nothing, + found_terminate, + found_cleanup, + found_handler + } found_type; + + lsda_header_info info; + const unsigned char *language_specific_data; + const unsigned char *action_record; + const unsigned char *p; + _Unwind_Ptr landing_pad, ip; + int handler_switch_value; + + bool hit_others_handler; + + struct _GNAT_Exception * gnat_exception; + + if (version != 1) + return _URC_FATAL_PHASE1_ERROR; + + START_DB (DB_PHASES); + decode_actions (actions); + END_DB (DB_PHASES); + + if (strcmp ( ((char *)&exception_class), "GNU") != 0 + || strcmp ( ((char *)&exception_class)+4, "Ada") != 0) + { + START_DB (DB_SEARCH); + printf (" Exception Class doesn't match for ip = %p\n", ip); + END_DB (DB_SEARCH); + START_DB (DB_FOUND); + printf (" => FOUND nothing\n"); + END_DB (DB_FOUND); + return _URC_CONTINUE_UNWIND; + } + + gnat_exception = (struct _GNAT_Exception *) ue_header; + + START_DB (DB_PHASES); + if (gnat_exception->select_cleanups) + { + printf ("(select_cleanups) :\n"); + } + else + { + printf (" :\n"); + } + END_DB (DB_PHASES); + + language_specific_data = (const unsigned char *) + _Unwind_GetLanguageSpecificData (context); + + /* If no LSDA, then there are no handlers or cleanups. */ + if (! language_specific_data) + { + ip = _Unwind_GetIP (context) - 1; + + START_DB (DB_SEARCH); + printf (" No Language Specific Data for ip = %p\n", ip); + END_DB (DB_SEARCH); + START_DB (DB_FOUND); + printf (" => FOUND nothing\n"); + END_DB (DB_FOUND); + return _URC_CONTINUE_UNWIND; + } + + /* Parse the LSDA header. */ + p = parse_lsda_header (context, language_specific_data, &info); + info.ttype_base = base_of_encoded_value (info.ttype_encoding, context); + ip = _Unwind_GetIP (context) - 1; + landing_pad = 0; + action_record = 0; + handler_switch_value = 0; + + /* Search the call-site table for the action associated with this IP. */ + while (p < info.action_table) + { + _Unwind_Ptr cs_start, cs_len, cs_lp, cs_action; + + /* Note that all call-site encodings are "absolute" displacements. */ + p = read_encoded_value (0, info.call_site_encoding, p, &cs_start); + p = read_encoded_value (0, info.call_site_encoding, p, &cs_len); + p = read_encoded_value (0, info.call_site_encoding, p, &cs_lp); + p = read_uleb128 (p, &cs_action); + + /* The table is sorted, so if we've passed the ip, stop. */ + if (ip < info.Start + cs_start) + p = info.action_table; + else if (ip < info.Start + cs_start + cs_len) + { + if (cs_lp) + landing_pad = info.LPStart + cs_lp; + if (cs_action) + action_record = info.action_table + cs_action - 1; + goto found_something; + } + } + + START_DB (DB_SEARCH); + printf (" No Action entry for ip = %p\n", ip); + END_DB (DB_SEARCH); + + /* If ip is not present in the table, call terminate. This is for + a destructor inside a cleanup, or a library routine the compiler + was not expecting to throw. + + found_type = + (actions & _UA_FORCE_UNWIND ? found_nothing : found_terminate); + + ??? Does this have a mapping in Ada semantics ? */ + + found_type = found_nothing; + + goto do_something; + + found_something: + + found_type = found_nothing; + + if (landing_pad == 0) + { + /* If ip is present, and has a null landing pad, there are + no cleanups or handlers to be run. */ + START_DB (DB_SEARCH); + printf (" No Landing Pad for ip = %p\n", ip); + END_DB (DB_SEARCH); + } + else if (action_record == 0) + { + START_DB (DB_SEARCH); + printf (" Null Action Record for ip = %p <===\n", ip); + END_DB (DB_SEARCH); + } + else + { + signed long ar_filter, ar_disp; + + signed long cleanup_filter = 0; + signed long handler_filter = 0; + + START_DB (DB_SEARCH); + printf (" Landing Pad + Action Record for ip = %p\n", ip); + END_DB (DB_SEARCH); + + START_DB (DB_MATCH); + printf (" => Search for exception matching id %p\n", + gnat_exception->id); + END_DB (DB_MATCH); + + /* Otherwise we have a catch handler or exception specification. */ + + while (1) + { + _Unwind_Ptr tmp; + + p = action_record; + p = read_sleb128 (p, &tmp); ar_filter = tmp; + read_sleb128 (p, &tmp); ar_disp = tmp; + + START_DB (DB_MATCH); + printf ("ar_filter %d\n", ar_filter); + END_DB (DB_MATCH); + + if (ar_filter == 0) + { + /* Zero filter values are cleanups. We should not be seeing + this for GNU-Ada though + saw_cleanup = true; */ + START_DB (DB_SEARCH); + printf (" Null Filter for ip = %p <===\n", ip); + END_DB (DB_SEARCH); + } + else if (ar_filter > 0) + { + _Unwind_Ptr lp_id = get_ttype_entry (context, &info, ar_filter); + + START_DB (DB_MATCH); + printf ("catch_type "); + + switch (lp_id) + { + case GNAT_ALL_OTHERS_ID: + printf ("GNAT_ALL_OTHERS_ID\n"); + break; + + case GNAT_OTHERS_ID: + printf ("GNAT_OTHERS_ID\n"); + break; + + default: + printf ("%p\n", lp_id); + break; + } + + END_DB (DB_MATCH); + + if (lp_id == GNAT_ALL_OTHERS_ID) + { + START_DB (DB_SAW); + printf (" => SAW cleanup\n"); + END_DB (DB_SAW); + + cleanup_filter = ar_filter; + gnat_exception->has_cleanup = true; + } + + hit_others_handler = + (lp_id == GNAT_OTHERS_ID && gnat_exception->handled_by_others); + + if (hit_others_handler || lp_id == gnat_exception->id) + { + START_DB (DB_SAW); + printf (" => SAW handler\n"); + END_DB (DB_SAW); + + handler_filter = ar_filter; + } + } + else + { + /* Negative filter values are for C++ exception specifications. + Should not be there for Ada :/ */ + } + + if (actions & _UA_SEARCH_PHASE) + { + if (handler_filter) + { + found_type = found_handler; + handler_switch_value = handler_filter; + break; + } + + if (cleanup_filter) + { + found_type = found_cleanup; + } + } + + if (actions & _UA_CLEANUP_PHASE) + { + if (handler_filter) + { + found_type = found_handler; + handler_switch_value = handler_filter; + break; + } + + if (cleanup_filter) + { + found_type = found_cleanup; + handler_switch_value = cleanup_filter; + break; + } + } + + if (ar_disp == 0) + break; + action_record = p + ar_disp; + } + } + + do_something: + if (found_type == found_nothing) { + START_DB (DB_FOUND); + printf (" => FOUND nothing\n"); + END_DB (DB_FOUND); + + return _URC_CONTINUE_UNWIND; + } + + if (actions & _UA_SEARCH_PHASE) + { + START_DB (DB_FOUND); + printf (" => Computing return for SEARCH\n"); + END_DB (DB_FOUND); + + if (found_type == found_cleanup + && !gnat_exception->select_cleanups) + { + START_DB (DB_FOUND); + printf (" => FOUND cleanup\n"); + END_DB (DB_FOUND); + + return _URC_CONTINUE_UNWIND; + } + + START_DB (DB_FOUND); + printf (" => FOUND handler\n"); + END_DB (DB_FOUND); + + return _URC_HANDLER_FOUND; + } + + install_context: + + START_DB (DB_INSTALL); + printf (" => INSTALLING context for filter %d\n", + handler_switch_value); + END_DB (DB_INSTALL); + + if (found_type == found_terminate) + { + /* Should not have this for Ada ? */ + START_DB (DB_INSTALL); + printf (" => FOUND terminate <===\n"); + END_DB (DB_INSTALL); + } + + + /* Signal that we are going to enter a handler, which will typically + enable the debugger to take control and possibly output an automatic + backtrace. Note that we are supposed to provide the handler's entry + point here but we don't have it. + */ + __gnat_notify_handled_exception + ((void *)landing_pad, hit_others_handler, true); + + + /* The GNU-Ada exception handlers know how to find the exception + occurrence without having to pass it as an argument so there + is no need to feed any specific register with this information. + + This is why the two following lines are commented out. */ + + /* _Unwind_SetGR (context, __builtin_eh_return_data_regno (0), + (_Unwind_Ptr) &xh->unwindHeader); */ + + _Unwind_SetGR (context, __builtin_eh_return_data_regno (1), + handler_switch_value); + + _Unwind_SetIP (context, landing_pad); + + return _URC_INSTALL_CONTEXT; +} + + +#endif /* IN_RTS - For eh personality routine */ diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 13149004416..816d851e480 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.79 $ +-- $Revision$ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- @@ -42,12 +42,8 @@ with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock -with Ada.Exceptions; --- used for Raise_Exception - package body System.Tasking.Protected_Objects is - use Ada.Exceptions; use System.Task_Primitives.Operations; ------------------------- @@ -97,7 +93,7 @@ package body System.Tasking.Protected_Objects is Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then - Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + raise Program_Error; end if; end Lock; @@ -111,7 +107,7 @@ package body System.Tasking.Protected_Objects is Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then - Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + raise Program_Error; end if; end Lock_Read_Only; diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index 36ada8c4c6f..53ed7ae1b89 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -610,8 +610,9 @@ package body Switch is when 'c' => Ptr := Ptr + 1; + if Ptr > Max then - Osint.Fail ("Invalid switch: ", "ec"); + raise Bad_Switch; end if; Config_File_Name := @@ -623,18 +624,17 @@ package body Switch is when 'm' => Ptr := Ptr + 1; + if Ptr > Max then - Osint.Fail ("Invalid switch: ", "em"); + raise Bad_Switch; end if; Mapping_File_Name := new String'(Switch_Chars (Ptr .. Max)); - return; when others => - Osint.Fail ("Invalid switch: ", - (1 => 'e', 2 => Switch_Chars (Ptr))); + raise Bad_Switch; end case; -- Processing for E switch |