bindgen.adb: Minor reformatting
* 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
From-SVN: r48195
This commit is contained in:
Geert Bosch
parent
a004eb826e
commit
17c5c8a5ee
19 changed files with 788 additions and 178 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
----------------
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 Path_Name_Of (File : File_Name_Type) return File_Name_Type is
|
||||
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 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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -3501,7 +3501,6 @@ package body Make is
|
|||
begin
|
||||
Delete_File (Name => Mapping_File_Name, Success => Success);
|
||||
end;
|
||||
|
||||
end if;
|
||||
|
||||
Exit_Program (E_Success);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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;
|
||||
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;
|
||||
|
|
|
|||
526
gcc/ada/raise.c
526
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 */
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue