+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.
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 \
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 \
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 \
s-fatlfl.ads \
s-fatllf.ads \
s-fatsfl.ads \
+ s-secsta.ads \
+ s-secsta.adb \
a-tags.ads \
a-tags.adb $(EXTRA_HIE_SOURCES)
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 \
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 \
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)
-- --
-- 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- --
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;
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);
-- 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;
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
end Exp_Strict;
-
----------------
-- Local_Atan --
----------------
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;");
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 = ");
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;
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));
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);
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;
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);
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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);
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
-- 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);
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 --
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
Write_Line (""" is truncated");
end Report_Truncated;
- -- start of procedure Initialize
+ -- Start of procedure Initialize
begin
Name_Len := File_Name'Length;
SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
loop
-
-- Get the unit name
Get_Line;
-- 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;
-- --
-- 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- --
-- 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);
with Alloc;
with Debug; use Debug;
-with Fmap;
+with Fmap; use Fmap;
with Krunch;
with Namet; use Namet;
with Opt; use Opt;
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
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;
-- 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
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 --
-- 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 --
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 --
-- --
-- B o d y --
-- --
--- $Revision: 1.21 $
+-- $Revision$
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- 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;
-- 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;
begin
Delete_File (Name => Mapping_File_Name, Success => Success);
end;
-
end if;
Exit_Program (E_Success);
-- --
------------------------------------------------------------------------------
-with Fmap;
+with Fmap; use Fmap;
with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
-- 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
-- Put the mapping of the spec or body contained in Data in the file
-- (3 lines).
+ ---------
+ -- Put --
+ ---------
+
procedure Put (S : String) is
Last : Natural;
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));
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);
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
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
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
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
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
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
-- 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;
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,
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.
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
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.
-- 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;
* *
* C Implementation File *
* *
- * $Revision: 1.1 $
+ * $Revision$
* *
* Copyright (C) 1992-2001, Free Software Foundation, Inc. *
* *
__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 */
-- --
-- B o d y --
-- --
--- $Revision: 1.79 $
+-- $Revision$
-- --
-- Copyright (C) 1991-2001 Florida State University --
-- --
-- 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;
-------------------------
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;
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;
when 'c' =>
Ptr := Ptr + 1;
+
if Ptr > Max then
- Osint.Fail ("Invalid switch: ", "ec");
+ raise Bad_Switch;
end if;
Config_File_Name :=
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
projects / thirdparty / gcc.git / commitdiff
