OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

New Language: Ada 

From-SVN: r45955
This commit is contained in:
Richard Kenner 2001-10-02 10:18:40 -04:00
parent 70482933d8
commit 38cbfe40a0
186 changed files with 82060 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1296
gcc/ada/g-awk.adb Normal file
View File

File diff suppressed because it is too large Load Diff

589
gcc/ada/g-awk.ads Normal file
View File

@ -0,0 +1,589 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A W K --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
--
-- This is an AWK-like unit. It provides an easy interface for parsing one
-- or more files containing formatted data. The file can be viewed seen as
-- a database where each record is a line and a field is a data element in
-- this line. In this implementation an AWK record is a line. This means
-- that a record cannot span multiple lines. The operating procedure is to
-- read files line by line, with each line being presented to the user of
-- the package. The interface provides services to access specific fields
-- in the line. Thus it is possible to control actions takn on a line based
-- on values of some fields. This can be achieved directly or by registering
-- callbacks triggered on programmed conditions.
--
-- The state of an AWK run is recorded in an object of type session.
-- The following is the procedure for using a session to control an
-- AWK run:
--
-- 1) Specify which session is to be used. It is possible to use the
-- default session or to create a new one by declaring an object of
-- type Session_Type. For example:
--
-- Computers : Session_Type;
--
-- 2) Specify how to cut a line into fields. There are two modes: using
-- character fields separators or column width. This is done by using
-- Set_Fields_Separators or Set_Fields_Width. For example by:
--
-- AWK.Set_Field_Separators (";,", Computers);
--
-- or by using iterators' Separators parameter.
--
-- 3) Specify which files to parse. This is done with Add_File/Add_Files
-- services, or by using the iterators' Filename parameter. For
-- example:
--
-- AWK.Add_File ("myfile.db", Computers);
--
-- 4) Run the AWK session using one of the provided iterators.
--
-- Parse
-- This is the most automated iterator. You can gain control on
-- the session only by registering one or more callbacks (see
-- Register).
--
-- Get_Line/End_Of_Data
-- This is a manual iterator to be used with a loop. You have
-- complete control on the session. You can use callbacks but
-- this is not required.
--
-- For_Every_Line
-- This provides a mixture of manual/automated iterator action.
--
-- Examples of these three approaches appear below
--
-- There is many ways to use this package. The following discussion shows
-- three approaches, using the three iterator forms, to using this package.
-- All examples will use the following file (computer.db):
--
-- Pluton;Windows-NT;Pentium III
-- Mars;Linux;Pentium Pro
-- Venus;Solaris;Sparc
-- Saturn;OS/2;i486
-- Jupiter;MacOS;PPC
--
-- 1) Using Parse iterator
--
-- Here the first step is to register some action associated to a pattern
-- and then to call the Parse iterator (this is the simplest way to use
-- this unit). The default session is used here. For example to output the
-- second field (the OS) of computer "Saturn".
--
-- procedure Action is
-- begin
-- Put_Line (AWK.Field (2));
-- end Action;
--
-- begin
-- AWK.Register (1, "Saturn", Action'Access);
-- AWK.Parse (";", "computer.db");
--
--
-- 2) Using the Get_Line/End_Of_Data iterator
--
-- Here you have full control. For example to do the same as
-- above but using a specific session, you could write:
--
-- Computer_File : Session_Type;
--
-- begin
-- AWK.Set_Current (Computer_File);
-- AWK.Open (Separators => ";",
-- Filename => "computer.db");
--
-- -- Display Saturn OS
--
-- while not AWK.End_Of_File loop
-- AWK.Get_Line;
--
-- if AWK.Field (1) = "Saturn" then
-- Put_Line (AWK.Field (2));
-- end if;
-- end loop;
--
-- AWK.Close (Computer_File);
--
--
-- 3) Using For_Every_Line iterator
--
-- In this case you use a provided iterator and you pass the procedure
-- that must be called for each record. You could code the previous
-- example could be coded as follows (using the iterator quick interface
-- but without using the current session):
--
-- Computer_File : Session_Type;
--
-- procedure Action (Quit : in out Boolean) is
-- begin
-- if AWK.Field (1, Computer_File) = "Saturn" then
-- Put_Line (AWK.Field (2, Computer_File));
-- end if;
-- end Action;
--
-- procedure Look_For_Saturn is
-- new AWK.For_Every_Line (Action);
--
-- begin
-- Look_For_Saturn (Separators => ";",
-- Filename => "computer.db",
-- Session => Computer_File);
--
-- Integer_Text_IO.Put
-- (Integer (AWK.NR (Session => Computer_File)));
-- Put_Line (" line(s) have been processed.");
--
-- You can also use a regular expression for the pattern. Let us output
-- the computer name for all computer for which the OS has a character
-- O in its name.
--
-- Regexp : String := ".*O.*";
--
-- Matcher : Regpat.Pattern_Matcher := Regpat.Compile (Regexp);
--
-- procedure Action is
-- begin
-- Text_IO.Put_Line (AWK.Field (2));
-- end Action;
--
-- begin
-- AWK.Register (2, Matcher, Action'Unrestricted_Access);
-- AWK.Parse (";", "computer.db");
--
with Ada.Finalization;
with GNAT.Regpat;
package GNAT.AWK is
Session_Error : exception;
-- Raised when a Session is reused but is not closed.
File_Error : exception;
-- Raised when there is a file problem (see below).
End_Error : exception;
-- Raised when an attempt is made to read beyond the end of the last
-- file of a session.
Field_Error : exception;
-- Raised when accessing a field value which does not exist.
Data_Error : exception;
-- Raised when it is not possible to convert a field value to a specific
-- type.
type Count is new Natural;
type Widths_Set is array (Positive range <>) of Positive;
-- Used to store a set of columns widths.
Default_Separators : constant String := " " & ASCII.HT;
Use_Current : constant String := "";
-- Value used when no separator or filename is specified in iterators.
type Session_Type is limited private;
-- This is the main exported type. A session is used to keep the state of
-- a full AWK run. The state comprises a list of files, the current file,
-- the number of line processed, the current line, the number of fields in
-- the current line... A default session is provided (see Set_Current,
-- Current_Session and Default_Session above).
----------------------------
-- Package initialization --
----------------------------
-- To be thread safe it is not possible to use the default provided
-- session. Each task must used a specific session and specify it
-- explicitly for every services.
procedure Set_Current (Session : Session_Type);
-- Set the session to be used by default. This file will be used when the
-- Session parameter in following services is not specified.
function Current_Session return Session_Type;
-- Returns the session used by default by all services. This is the
-- latest session specified by Set_Current service or the session
-- provided by default with this implementation.
function Default_Session return Session_Type;
-- Returns the default session provided by this package. Note that this is
-- the session return by Current_Session if Set_Current has not been used.
procedure Set_Field_Separators
(Separators : String := Default_Separators;
Session : Session_Type := Current_Session);
-- Set the field separators. Each character in the string is a field
-- separator. When a line is read it will be split by field using the
-- separators set here. Separators can be changed at any point and in this
-- case the current line is split according to the new separators. In the
-- special case that Separators is a space and a tabulation
-- (Default_Separators), fields are separated by runs of spaces and/or
-- tabs.
procedure Set_FS
(Separators : String := Default_Separators;
Session : Session_Type := Current_Session)
renames Set_Field_Separators;
-- FS is the AWK abbreviation for above service.
procedure Set_Field_Widths
(Field_Widths : Widths_Set;
Session : Session_Type := Current_Session);
-- This is another way to split a line by giving the length (in number of
-- characters) of each field in a line. Field widths can be changed at any
-- point and in this case the current line is split according to the new
-- field lengths. A line split with this method must have a length equal or
-- greater to the total of the field widths. All characters remaining on
-- the line after the latest field are added to a new automatically
-- created field.
procedure Add_File
(Filename : String;
Session : Session_Type := Current_Session);
-- Add Filename to the list of file to be processed. There is no limit on
-- the number of files that can be added. Files are processed in the order
-- they have been added (i.e. the filename list is FIFO). If Filename does
-- not exist or if it is not readable, File_Error is raised.
procedure Add_Files
(Directory : String;
Filenames : String;
Number_Of_Files_Added : out Natural;
Session : Session_Type := Current_Session);
-- Add all files matching the regular expression Filenames in the specified
-- directory to the list of file to be processed. There is no limit on
-- the number of files that can be added. Each file is processed in
-- the same order they have been added (i.e. the filename list is FIFO).
-- The number of files (possibly 0) added is returned in
-- Number_Of_Files_Added.
-------------------------------------
-- Information about current state --
-------------------------------------
function Number_Of_Fields
(Session : Session_Type := Current_Session)
return Count;
-- Returns the number of fields in the current record. It returns 0 when
-- no file is being processed.
function NF
(Session : Session_Type := Current_Session)
return Count
renames Number_Of_Fields;
-- AWK abbreviation for above service.
function Number_Of_File_Lines
(Session : Session_Type := Current_Session)
return Count;
-- Returns the current line number in the processed file. It returns 0 when
-- no file is being processed.
function FNR
(Session : Session_Type := Current_Session)
return Count renames Number_Of_File_Lines;
-- AWK abbreviation for above service.
function Number_Of_Lines
(Session : Session_Type := Current_Session)
return Count;
-- Returns the number of line processed until now. This is equal to number
-- of line in each already processed file plus FNR. It returns 0 when
-- no file is being processed.
function NR
(Session : Session_Type := Current_Session)
return Count
renames Number_Of_Lines;
-- AWK abbreviation for above service.
function Number_Of_Files
(Session : Session_Type := Current_Session)
return Natural;
-- Returns the number of files associated with Session. This is the total
-- number of files added with Add_File and Add_Files services.
function File
(Session : Session_Type := Current_Session)
return String;
-- Returns the name of the file being processed. It returns the empty
-- string when no file is being processed.
---------------------
-- Field accessors --
---------------------
function Field
(Rank : Count;
Session : Session_Type := Current_Session)
return String;
-- Returns field number Rank value of the current record. If Rank = 0 it
-- returns the current record (i.e. the line as read in the file). It
-- raises Field_Error if Rank > NF or if Session is not open.
function Field
(Rank : Count;
Session : Session_Type := Current_Session)
return Integer;
-- Returns field number Rank value of the current record as an integer. It
-- raises Field_Error if Rank > NF or if Session is not open. It
-- raises Data_Error if the field value cannot be converted to an integer.
function Field
(Rank : Count;
Session : Session_Type := Current_Session)
return Float;
-- Returns field number Rank value of the current record as a float. It
-- raises Field_Error if Rank > NF or if Session is not open. It
-- raises Data_Error if the field value cannot be converted to a float.
generic
type Discrete is (<>);
function Discrete_Field
(Rank : Count;
Session : Session_Type := Current_Session)
return Discrete;
-- Returns field number Rank value of the current record as a type
-- Discrete. It raises Field_Error if Rank > NF. It raises Data_Error if
-- the field value cannot be converted to type Discrete.
--------------------
-- Pattern/Action --
--------------------
-- AWK defines rules like "PATTERN { ACTION }". Which means that ACTION
-- will be executed if PATTERN match. A pattern in this implementation can
-- be a simple string (match function is equality), a regular expression,
-- a function returning a boolean. An action is associated to a pattern
-- using the Register services.
--
-- Each procedure Register will add a rule to the set of rules for the
-- session. Rules are examined in the order they have been added.
type Pattern_Callback is access function return Boolean;
-- This is a pattern function pointer. When it returns True the associated
-- action will be called.
type Action_Callback is access procedure;
-- A simple action pointer
type Match_Action_Callback is
access procedure (Matches : GNAT.Regpat.Match_Array);
-- An advanced action pointer used with a regular expression pattern. It
-- returns an array of all the matches. See GNAT.Regpat for further
-- information.
procedure Register
(Field : Count;
Pattern : String;
Action : Action_Callback;
Session : Session_Type := Current_Session);
-- Register an Action associated with a Pattern. The pattern here is a
-- simple string that must match exactly the field number specified.
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Action_Callback;
Session : Session_Type := Current_Session);
-- Register an Action associated with a Pattern. The pattern here is a
-- simple regular expression which must match the field number specified.
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Match_Action_Callback;
Session : Session_Type := Current_Session);
-- Same as above but it pass the set of matches to the action
-- procedure. This is useful to analyse further why and where a regular
-- expression did match.
procedure Register
(Pattern : Pattern_Callback;
Action : Action_Callback;
Session : Session_Type := Current_Session);
-- Register an Action associated with a Pattern. The pattern here is a
-- function that must return a boolean. Action callback will be called if
-- the pattern callback returns True and nothing will happen if it is
-- False. This version is more general, the two other register services
-- trigger an action based on the value of a single field only.
procedure Register
(Action : Action_Callback;
Session : Session_Type := Current_Session);
-- Register an Action that will be called for every line. This is
-- equivalent to a Pattern_Callback function always returning True.
--------------------
-- Parse iterator --
--------------------
procedure Parse
(Separators : String := Use_Current;
Filename : String := Use_Current;
Session : Session_Type := Current_Session);
-- Launch the iterator, it will read every line in all specified
-- session's files. Registered callbacks are then called if the associated
-- pattern match. It is possible to specify a filename and a set of
-- separators directly. This offer a quick way to parse a single
-- file. These parameters will override those specified by Set_FS and
-- Add_File. The Session will be opened and closed automatically.
-- File_Error is raised if there is no file associated with Session, or if
-- a file associated with Session is not longer readable. It raises
-- Session_Error is Session is already open.
-----------------------------------
-- Get_Line/End_Of_Data Iterator --
-----------------------------------
type Callback_Mode is (None, Only, Pass_Through);
-- These mode are used for Get_Line/End_Of_Data and For_Every_Line
-- iterators. The associated semantic is:
--
-- None
-- callbacks are not active. This is the default mode for
-- Get_Line/End_Of_Data and For_Every_Line iterators.
--
-- Only
-- callbacks are active, if at least one pattern match, the associated
-- action is called and this line will not be passed to the user. In
-- the Get_Line case the next line will be read (if there is some
-- line remaining), in the For_Every_Line case Action will
-- not be called for this line.
--
-- Pass_Through
-- callbacks are active, for patterns which match the associated
-- action is called. Then the line is passed to the user. It means
-- that Action procedure is called in the For_Every_Line case and
-- that Get_Line returns with the current line active.
--
procedure Open
(Separators : String := Use_Current;
Filename : String := Use_Current;
Session : Session_Type := Current_Session);
-- Open the first file and initialize the unit. This must be called once
-- before using Get_Line. It is possible to specify a filename and a set of
-- separators directly. This offer a quick way to parse a single file.
-- These parameters will override those specified by Set_FS and Add_File.
-- File_Error is raised if there is no file associated with Session, or if
-- the first file associated with Session is no longer readable. It raises
-- Session_Error is Session is already open.
procedure Get_Line
(Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session);
-- Read a line from the current input file. If the file index is at the
-- end of the current input file (i.e. End_Of_File is True) then the
-- following file is opened. If there is no more file to be processed,
-- exception End_Error will be raised. File_Error will be raised if Open
-- has not been called. Next call to Get_Line will return the following
-- line in the file. By default the registered callbacks are not called by
-- Get_Line, this can activated by setting Callbacks (see Callback_Mode
-- description above). File_Error may be raised if a file associated with
-- Session is not readable.
--
-- When Callbacks is not None, it is possible to exhaust all the lines
-- of all the files associated with Session. In this case, File_Error
-- is not raised.
--
-- This procedure can be used from a subprogram called by procedure Parse
-- or by an instantiation of For_Every_Line (see below).
function End_Of_Data
(Session : Session_Type := Current_Session)
return Boolean;
-- Returns True if there is no more data to be processed in Session. It
-- means that the latest session's file is being processed and that
-- there is no more data to be read in this file (End_Of_File is True).
function End_Of_File
(Session : Session_Type := Current_Session)
return Boolean;
-- Returns True when there is no more data to be processed on the current
-- session's file.
procedure Close (Session : Session_Type);
-- Release all associated data with Session. All memory allocated will
-- be freed, the current file will be closed if needed, the callbacks
-- will be unregistered. Close is convenient in reestablishing a session
-- for new use. Get_Line is no longer usable (will raise File_Error)
-- except after a successful call to Open, Parse or an instantiation
-- of For_Every_Line.
-----------------------------
-- For_Every_Line iterator --
-----------------------------
generic
with procedure Action (Quit : in out Boolean);
procedure For_Every_Line
(Separators : String := Use_Current;
Filename : String := Use_Current;
Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session);
-- This is another iterator. Action will be called for each new
-- record. The iterator's termination can be controlled by setting Quit
-- to True. It is by default set to False. It is possible to specify a
-- filename and a set of separators directly. This offer a quick way to
-- parse a single file. These parameters will override those specified by
-- Set_FS and Add_File. By default the registered callbacks are not called
-- by For_Every_Line, this can activated by setting Callbacks (see
-- Callback_Mode description above). The Session will be opened and
-- closed automatically. File_Error is raised if there is no file
-- associated with Session. It raises Session_Error is Session is already
-- open.
private
pragma Inline (End_Of_File);
pragma Inline (End_Of_Data);
pragma Inline (Number_Of_Fields);
pragma Inline (Number_Of_Lines);
pragma Inline (Number_Of_Files);
pragma Inline (Number_Of_File_Lines);
type Session_Data;
type Session_Data_Access is access Session_Data;
type Session_Type is new Ada.Finalization.Limited_Controlled with record
Data : Session_Data_Access;
end record;
procedure Initialize (Session : in out Session_Type);
procedure Finalize (Session : in out Session_Type);
end GNAT.AWK;

61
gcc/ada/g-busora.adb Normal file
View File

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ A --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Bubble_Sort_A is
----------
-- Sort --
----------
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is
Switched : Boolean;
begin
loop
Switched := False;
for J in 1 .. N - 1 loop
if Lt (J + 1, J) then
Move (J, 0);
Move (J + 1, J);
Move (0, J + 1);
Switched := True;
end if;
end loop;
exit when not Switched;
end loop;
end Sort;
end GNAT.Bubble_Sort_A;

68
gcc/ada/g-busora.ads Normal file
View File

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ A --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Bubblesort using access to procedure parameters
-- This package provides a bubblesort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
-- shared sorting code. See also GNAT.Bubble_Sort_G, the generic version
-- which is a little more efficient, but does not allow code sharing.
-- The generic version is also Pure, while the access version can
-- only be Preelaborate.
package GNAT.Bubble_Sort_A is
pragma Preelaborate (Bubble_Sort_A);
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
type Move_Procedure is access procedure (From : Natural; To : Natural);
-- A pointer to a procedure that moves the data item with index From to
-- the data item with index To. An index value of zero is used for moves
-- from and to the single temporary location used by the sort.
type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
-- A pointer to a function that compares two items and returns True if
-- the item with index Op1 is less than the item with index Op2, and False
-- if the Op2 item is greater than or equal to the Op1 item.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Bubble_Sort_A;

61
gcc/ada/g-busorg.adb Normal file
View File

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ G --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Bubble_Sort_G is
----------
-- Sort --
----------
procedure Sort (N : Natural) is
Switched : Boolean;
begin
loop
Switched := False;
for J in 1 .. N - 1 loop
if Lt (J + 1, J) then
Move (J, 0);
Move (J + 1, J);
Move (0, J + 1);
Switched := True;
end if;
end loop;
exit when not Switched;
end loop;
end Sort;
end GNAT.Bubble_Sort_G;

68
gcc/ada/g-busorg.ads Normal file
View File

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . B U B B L E _ S O R T _ G --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Bubblesort generic package using formal procedures
-- This package provides a generic bubble sort routine that can be used with
-- different types of data. See also GNAT.Bubble_Sort_A, a version that works
-- with subprogram parameters, allowing code sharing. The generic version
-- is slightly more efficient but does not allow code sharing. The generic
-- version is also Pure, while the access version can only be Preelaborate.
generic
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
-- A procedure that moves the data item with index From to the data item
-- with Index To. An index value of zero is used for moves from and to a
-- single temporary location used by the sort.
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
-- index Op1 is less than the item with Index Op2, and False if the Op2
-- item is greater than or equal to the Op1 item.
package GNAT.Bubble_Sort_G is
pragma Pure (Bubble_Sort_G);
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Bubble_Sort_G;

319
gcc/ada/g-calend.adb Normal file
View File

@ -0,0 +1,319 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Calendar is
use Ada.Calendar;
use Interfaces;
-----------------
-- Day_In_Year --
-----------------
function Day_In_Year (Date : Time) return Day_In_Year_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Dsecs : Day_Duration;
begin
Split (Date, Year, Month, Day, Dsecs);
return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
end Day_In_Year;
-----------------
-- Day_Of_Week --
-----------------
function Day_Of_Week (Date : Time) return Day_Name is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Dsecs : Day_Duration;
begin
Split (Date, Year, Month, Day, Dsecs);
return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
end Day_Of_Week;
----------
-- Hour --
----------
function Hour (Date : Time) return Hour_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Hour;
end Hour;
----------------
-- Julian_Day --
----------------
-- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note
-- that this implementation is not expensive.
function Julian_Day
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number)
return Integer
is
Internal_Year : Integer;
Internal_Month : Integer;
Internal_Day : Integer;
Julian_Date : Integer;
C : Integer;
Ya : Integer;
begin
Internal_Year := Integer (Year);
Internal_Month := Integer (Month);
Internal_Day := Integer (Day);
if Internal_Month > 2 then
Internal_Month := Internal_Month - 3;
else
Internal_Month := Internal_Month + 9;
Internal_Year := Internal_Year - 1;
end if;
C := Internal_Year / 100;
Ya := Internal_Year - (100 * C);
Julian_Date := (146_097 * C) / 4 +
(1_461 * Ya) / 4 +
(153 * Internal_Month + 2) / 5 +
Internal_Day + 1_721_119;
return Julian_Date;
end Julian_Day;
------------
-- Minute --
------------
function Minute (Date : Time) return Minute_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Minute;
end Minute;
------------
-- Second --
------------
function Second (Date : Time) return Second_Number is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Second;
end Second;
-----------
-- Split --
-----------
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Hour : out Hour_Number;
Minute : out Minute_Number;
Second : out Second_Number;
Sub_Second : out Second_Duration)
is
Dsecs : Day_Duration;
Secs : Natural;
begin
Split (Date, Year, Month, Day, Dsecs);
if Dsecs = 0.0 then
Secs := 0;
else
Secs := Natural (Dsecs - 0.5);
end if;
Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs));
Hour := Hour_Number (Secs / 3600);
Secs := Secs mod 3600;
Minute := Minute_Number (Secs / 60);
Second := Second_Number (Secs mod 60);
end Split;
----------------
-- Sub_Second --
----------------
function Sub_Second (Date : Time) return Second_Duration is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Sub_Second;
end Sub_Second;
-------------
-- Time_Of --
-------------
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration := 0.0)
return Time
is
Dsecs : constant Day_Duration :=
Day_Duration (Hour * 3600 + Minute * 60 + Second) +
Sub_Second;
begin
return Time_Of (Year, Month, Day, Dsecs);
end Time_Of;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : access timeval) return Duration is
procedure timeval_to_duration
(T : access timeval;
sec : access C.long;
usec : access C.long);
pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
Micro : constant := 10**6;
sec : aliased C.long;
usec : aliased C.long;
begin
timeval_to_duration (T, sec'Access, usec'Access);
return Duration (sec) + Duration (usec) / Micro;
end To_Duration;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return timeval is
procedure duration_to_timeval (Sec, Usec : C.long; T : access timeval);
pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
Micro : constant := 10**6;
Result : aliased timeval;
sec : C.long;
usec : C.long;
begin
if D = 0.0 then
sec := 0;
usec := 0;
else
sec := C.long (D - 0.5);
usec := C.long ((D - Duration (sec)) * Micro - 0.5);
end if;
duration_to_timeval (sec, usec, Result'Access);
return Result;
end To_Timeval;
------------------
-- Week_In_Year --
------------------
function Week_In_Year
(Date : Ada.Calendar.Time)
return Week_In_Year_Number
is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
Offset : Natural;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
-- Day offset number for the first week of the year.
Offset := Julian_Day (Year, 1, 1) mod 7;
return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
end Week_In_Year;
end GNAT.Calendar;

131
gcc/ada/g-calend.ads Normal file
View File

@ -0,0 +1,131 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1999-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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package extends Ada.Calendar to handle Hour, Minute, Second,
-- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time.
-- Second_Duration precision depends on the target clock precision.
--
-- GNAT.Calendar provides the same kind of abstraction found in
-- Ada.Calendar. It provides Split and Time_Of to build and split a Time
-- data. And it provides accessor functions to get only one of Hour, Minute,
-- Second, Second_Duration. Other functions are to access more advanced
-- valueas like Day_Of_Week, Day_In_Year and Week_In_Year.
with Ada.Calendar;
with Interfaces.C;
package GNAT.Calendar is
type Day_Name is
(Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday);
subtype Hour_Number is Natural range 0 .. 23;
subtype Minute_Number is Natural range 0 .. 59;
subtype Second_Number is Natural range 0 .. 59;
subtype Second_Duration is Ada.Calendar.Day_Duration range 0.0 .. 1.0;
subtype Day_In_Year_Number is Positive range 1 .. 366;
subtype Week_In_Year_Number is Positive range 1 .. 53;
function Hour (Date : Ada.Calendar.Time) return Hour_Number;
function Minute (Date : Ada.Calendar.Time) return Minute_Number;
function Second (Date : Ada.Calendar.Time) return Second_Number;
function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration;
-- Hour, Minute, Sedond and Sub_Second returns the complete time data for
-- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors.
-- Second_Duration precision depends on the target clock precision.
function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name;
-- Return the day name.
function Day_In_Year (Date : Ada.Calendar.Time) return Day_In_Year_Number;
-- Returns the day number in the year. (1st January is day 1 and 31st
-- December is day 365 or 366 for leap year).
function Week_In_Year (Date : Ada.Calendar.Time) return Week_In_Year_Number;
-- Returns the week number in the year with Monday as first day of week
procedure Split
(Date : Ada.Calendar.Time;
Year : out Ada.Calendar.Year_Number;
Month : out Ada.Calendar.Month_Number;
Day : out Ada.Calendar.Day_Number;
Hour : out Hour_Number;
Minute : out Minute_Number;
Second : out Second_Number;
Sub_Second : out Second_Duration);
-- Split the standard Ada.Calendar.Time data in date data (Year, Month,
-- Day) and Time data (Hour, Minute, Second, Sub_Second)
function Time_Of
(Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
Day : Ada.Calendar.Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration := 0.0)
return Ada.Calendar.Time;
-- Returns an Ada.Calendar.Time data built from the date and time values.
-- C timeval conversion
-- C timeval represent a duration (used in Select for example). This
-- structure is composed of a number of seconds and a number of micro
-- seconds. The timeval structure is not exposed here because its
-- definition is target dependent. Interface to C programs is done via a
-- pointer to timeval structure.
type timeval is private;
function To_Duration (T : access timeval) return Duration;
function To_Timeval (D : Duration) return timeval;
private
-- This is a dummy declaration that should be the largest possible timeval
-- structure of all supported targets.
type timeval is array (1 .. 2) of Interfaces.C.long;
function Julian_Day
(Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
Day : Ada.Calendar.Day_Number)
return Integer;
-- Compute Julian day number.
--
-- The code of this function is a modified version of algorithm
-- 199 from the Collected Algorithms of the ACM.
-- The author of algorithm 199 is Robert G. Tantzen.
end GNAT.Calendar;

106
gcc/ada/g-casuti.adb Normal file
View File

@ -0,0 +1,106 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . C A S E _ U T I L --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Case_Util is
--------------
-- To_Lower --
--------------
function To_Lower (A : Character) return Character is
A_Val : constant Natural := Character'Pos (A);
begin
if A in 'A' .. 'Z'
or else A_Val in 16#C0# .. 16#D6#
or else A_Val in 16#D8# .. 16#DE#
then
return Character'Val (A_Val + 16#20#);
else
return A;
end if;
end To_Lower;
procedure To_Lower (A : in out String) is
begin
for J in A'Range loop
A (J) := To_Lower (A (J));
end loop;
end To_Lower;
--------------
-- To_Mixed --
--------------
procedure To_Mixed (A : in out String) is
Ucase : Boolean := True;
begin
for J in A'Range loop
if Ucase then
A (J) := To_Upper (A (J));
else
A (J) := To_Lower (A (J));
end if;
Ucase := A (J) = '_';
end loop;
end To_Mixed;
--------------
-- To_Upper --
--------------
function To_Upper (A : Character) return Character is
A_Val : constant Natural := Character'Pos (A);
begin
if A in 'a' .. 'z'
or else A_Val in 16#E0# .. 16#F6#
or else A_Val in 16#F8# .. 16#FE#
then
return Character'Val (A_Val - 16#20#);
else
return A;
end if;
end To_Upper;
procedure To_Upper (A : in out String) is
begin
for J in A'Range loop
A (J) := To_Upper (A (J));
end loop;
end To_Upper;
end GNAT.Case_Util;

64
gcc/ada/g-casuti.ads Normal file
View File

@ -0,0 +1,64 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . C A S E _ U T I L --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Simple casing functions
-- This package provides simple casing functions that do not require the
-- overhead of the full casing tables found in Ada.Characters.Handling.
package GNAT.Case_Util is
pragma Pure (Case_Util);
-- Note: all the following functions handle the full Latin-1 set
function To_Upper (A : Character) return Character;
-- Converts A to upper case if it is a lower case letter, otherwise
-- returns the input argument unchanged.
procedure To_Upper (A : in out String);
-- Folds all characters of string A to upper csae
function To_Lower (A : Character) return Character;
-- Converts A to lower case if it is an upper case letter, otherwise
-- returns the input argument unchanged.
procedure To_Lower (A : in out String);
-- Folds all characters of string A to lower case
procedure To_Mixed (A : in out String);
-- Converts A to mixed case (i.e. lower case, except for initial
-- character and any character after an underscore, which are
-- converted to upper case.
end GNAT.Case_Util;

465
gcc/ada/g-catiio.adb Normal file
View File

@ -0,0 +1,465 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R . T I M E _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Calendar; use Ada.Calendar;
with Ada.Characters.Handling;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;
package body GNAT.Calendar.Time_IO is
type Month_Name is
(January,
Febuary,
March,
April,
May,
June,
July,
August,
September,
October,
November,
December);
type Padding_Mode is (None, Zero, Space);
-----------------------
-- Local Subprograms --
-----------------------
function Am_Pm (H : Natural) return String;
-- return AM or PM depending on the hour H
function Hour_12 (H : Natural) return Positive;
-- Convert a 1-24h format to a 0-12 hour format.
function Image (Str : String; Length : Natural := 0) return String;
-- Return Str capitalized and cut to length number of characters. If
-- length is set to 0 it does not cut it.
function Image
(N : Long_Integer;
Padding : Padding_Mode := Zero;
Length : Natural := 0)
return String;
-- Return image of N. This number is eventually padded with zeros or
-- spaces depending of the length required. If length is 0 then no padding
-- occurs.
function Image
(N : Integer;
Padding : Padding_Mode := Zero;
Length : Natural := 0)
return String;
-- As above with N provided in Integer format.
-----------
-- Am_Pm --
-----------
function Am_Pm (H : Natural) return String is
begin
if H = 0 or else H > 12 then
return "PM";
else
return "AM";
end if;
end Am_Pm;
-------------
-- Hour_12 --
-------------
function Hour_12 (H : Natural) return Positive is
begin
if H = 0 then
return 12;
elsif H <= 12 then
return H;
else -- H > 12
return H - 12;
end if;
end Hour_12;
-----------
-- Image --
-----------
function Image
(Str : String;
Length : Natural := 0)
return String
is
use Ada.Characters.Handling;
Local : String := To_Upper (Str (1)) & To_Lower (Str (2 .. Str'Last));
begin
if Length = 0 then
return Local;
else
return Local (1 .. Length);
end if;
end Image;
-----------
-- Image --
-----------
function Image
(N : Integer;
Padding : Padding_Mode := Zero;
Length : Natural := 0)
return String
is
begin
return Image (Long_Integer (N), Padding, Length);
end Image;
function Image
(N : Long_Integer;
Padding : Padding_Mode := Zero;
Length : Natural := 0)
return String
is
function Pad_Char return String;
function Pad_Char return String is
begin
case Padding is
when None => return "";
when Zero => return "00";
when Space => return " ";
end case;
end Pad_Char;
NI : constant String := Long_Integer'Image (N);
NIP : constant String := Pad_Char & NI (2 .. NI'Last);
-- Start of processing for Image
begin
if Length = 0 or else Padding = None then
return NI (2 .. NI'Last);
else
return NIP (NIP'Last - Length + 1 .. NIP'Last);
end if;
end Image;
-----------
-- Image --
-----------
function Image
(Date : Ada.Calendar.Time;
Picture : Picture_String)
return String
is
Padding : Padding_Mode := Zero;
-- Padding is set for one directive
Result : Unbounded_String;
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
P : Positive := Picture'First;
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
loop
-- A directive has the following format "%[-_]."
if Picture (P) = '%' then
Padding := Zero;
if P = Picture'Last then
raise Picture_Error;
end if;
-- Check for GNU extension to change the padding
if Picture (P + 1) = '-' then
Padding := None;
P := P + 1;
elsif Picture (P + 1) = '_' then
Padding := Space;
P := P + 1;
end if;
if P = Picture'Last then
raise Picture_Error;
end if;
case Picture (P + 1) is
-- Literal %
when '%' =>
Result := Result & '%';
-- A newline
when 'n' =>
Result := Result & ASCII.LF;
-- A horizontal tab
when 't' =>
Result := Result & ASCII.HT;
-- Hour (00..23)
when 'H' =>
Result := Result & Image (Hour, Padding, 2);
-- Hour (01..12)
when 'I' =>
Result := Result & Image (Hour_12 (Hour), Padding, 2);
-- Hour ( 0..23)
when 'k' =>
Result := Result & Image (Hour, Space, 2);
-- Hour ( 1..12)
when 'l' =>
Result := Result & Image (Hour_12 (Hour), Space, 2);
-- Minute (00..59)
when 'M' =>
Result := Result & Image (Minute, Padding, 2);
-- AM/PM
when 'p' =>
Result := Result & Am_Pm (Hour);
-- Time, 12-hour (hh:mm:ss [AP]M)
when 'r' =>
Result := Result &
Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
Image (Minute, Padding, Length => 2) & ':' &
Image (Second, Padding, Length => 2) & ' ' &
Am_Pm (Hour);
-- Seconds since 1970-01-01 00:00:00 UTC
-- (a nonstandard extension)
when 's' =>
declare
Sec : constant Long_Integer :=
Long_Integer
((Julian_Day (Year, Month, Day) -
Julian_Day (1970, 1, 1)) * 86_400 +
Hour * 3_600 + Minute * 60 + Second);
begin
Result := Result & Image (Sec, None);
end;
-- Second (00..59)
when 'S' =>
Result := Result & Image (Second, Padding, Length => 2);
-- Time, 24-hour (hh:mm:ss)
when 'T' =>
Result := Result &
Image (Hour, Padding, Length => 2) & ':' &
Image (Minute, Padding, Length => 2) & ':' &
Image (Second, Padding, Length => 2);
-- Locale's abbreviated weekday name (Sun..Sat)
when 'a' =>
Result := Result &
Image (Day_Name'Image (Day_Of_Week (Date)), 3);
-- Locale's full weekday name, variable length
-- (Sunday..Saturday)
when 'A' =>
Result := Result &
Image (Day_Name'Image (Day_Of_Week (Date)));
-- Locale's abbreviated month name (Jan..Dec)
when 'b' | 'h' =>
Result := Result &
Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
-- Locale's full month name, variable length
-- (January..December)
when 'B' =>
Result := Result &
Image (Month_Name'Image (Month_Name'Val (Month - 1)));
-- Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
when 'c' =>
case Padding is
when Zero =>
Result := Result & Image (Date, "%a %b %d %T %Y");
when Space =>
Result := Result & Image (Date, "%a %b %_d %_T %Y");
when None =>
Result := Result & Image (Date, "%a %b %-d %-T %Y");
end case;
-- Day of month (01..31)
when 'd' =>
Result := Result & Image (Day, Padding, 2);
-- Date (mm/dd/yy)
when 'D' | 'x' =>
Result := Result &
Image (Month, Padding, 2) & '/' &
Image (Day, Padding, 2) & '/' &
Image (Year, Padding, 2);
-- Day of year (001..366)
when 'j' =>
Result := Result & Image (Day_In_Year (Date), Padding, 3);
-- Month (01..12)
when 'm' =>
Result := Result & Image (Month, Padding, 2);
-- Week number of year with Sunday as first day of week
-- (00..53)
when 'U' =>
declare
Offset : constant Natural :=
(Julian_Day (Year, 1, 1) + 1) mod 7;
Week : constant Natural :=
1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
begin
Result := Result & Image (Week, Padding, 2);
end;
-- Day of week (0..6) with 0 corresponding to Sunday
when 'w' =>
declare
DOW : Natural range 0 .. 6;
begin
if Day_Of_Week (Date) = Sunday then
DOW := 0;
else
DOW := Day_Name'Pos (Day_Of_Week (Date));
end if;
Result := Result & Image (DOW, Length => 1);
end;
-- Week number of year with Monday as first day of week
-- (00..53)
when 'W' =>
Result := Result & Image (Week_In_Year (Date), Padding, 2);
-- Last two digits of year (00..99)
when 'y' =>
declare
Y : constant Natural := Year - (Year / 100) * 100;
begin
Result := Result & Image (Y, Padding, 2);
end;
-- Year (1970...)
when 'Y' =>
Result := Result & Image (Year, None, 4);
when others =>
raise Picture_Error;
end case;
P := P + 2;
else
Result := Result & Picture (P);
P := P + 1;
end if;
exit when P > Picture'Last;
end loop;
return To_String (Result);
end Image;
--------------
-- Put_Time --
--------------
procedure Put_Time
(Date : Ada.Calendar.Time;
Picture : Picture_String)
is
begin
Ada.Text_IO.Put (Image (Date, Picture));
end Put_Time;
end GNAT.Calendar.Time_IO;

131
gcc/ada/g-catiio.ads Normal file
View File

@ -0,0 +1,131 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C A L E N D A R . T I M E _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package augments standard Ada.Text_IO with facilities for input
-- and output of time values in standardized format.
package GNAT.Calendar.Time_IO is
Picture_Error : exception;
type Picture_String is new String;
-- This is a string to describe date and time output format. The string is
-- a set of standard character and special tag that are replaced by the
-- corresponding values. It follows the GNU Date specification. Here are
-- the recognized directives :
--
-- % a literal %
-- n a newline
-- t a horizontal tab
--
-- Time fields:
--
-- %H hour (00..23)
-- %I hour (01..12)
-- %k hour ( 0..23)
-- %l hour ( 1..12)
-- %M minute (00..59)
-- %p locale's AM or PM
-- %r time, 12-hour (hh:mm:ss [AP]M)
-- %s seconds since 1970-01-01 00:00:00 UTC
-- (a nonstandard extension)
-- %S second (00..59)
-- %T time, 24-hour (hh:mm:ss)
--
-- Date fields:
--
-- %a locale's abbreviated weekday name (Sun..Sat)
-- %A locale's full weekday name, variable length
-- (Sunday..Saturday)
-- %b locale's abbreviated month name (Jan..Dec)
-- %B locale's full month name, variable length
-- (January..December)
-- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989)
-- %d day of month (01..31)
-- %D date (mm/dd/yy)
-- %h same as %b
-- %j day of year (001..366)
-- %m month (01..12)
-- %U week number of year with Sunday as first day of week
-- (00..53)
-- %w day of week (0..6) with 0 corresponding to Sunday
-- %W week number of year with Monday as first day of week
-- (00..53)
-- %x locale's date representation (mm/dd/yy)
-- %y last two digits of year (00..99)
-- %Y year (1970...)
--
-- By default, date pads numeric fields with zeroes. GNU date
-- recognizes the following nonstandard numeric modifiers:
--
-- - (hyphen) do not pad the field
-- _ (underscore) pad the field with spaces
ISO_Date : constant Picture_String;
-- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD",
-- four digits year, month and day number separated by minus.
US_Date : constant Picture_String;
-- This format is the common US date format: "MM/DD/YY",
-- month and day number, two digits year separated by slashes.
European_Date : constant Picture_String;
-- This format is the common European date format: "DD/MM/YY",
-- day and month number, two digits year separated by slashes.
function Image
(Date : Ada.Calendar.Time;
Picture : Picture_String)
return String;
-- Return Date as a string with format Picture.
-- raise Picture_Error if picture string is wrong
procedure Put_Time
(Date : Ada.Calendar.Time;
Picture : Picture_String);
-- Put Date with format Picture.
-- raise Picture_Error if picture string is wrong
private
ISO_Date : constant Picture_String := "%Y-%m-%d";
US_Date : constant Picture_String := "%m/%d/%y";
European_Date : constant Picture_String := "%d/%m/%y";
end GNAT.Calendar.Time_IO;

491
gcc/ada/g-cgi.adb Normal file
View File

@ -0,0 +1,491 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Handling;
with Ada.Strings.Maps;
with GNAT.OS_Lib;
with GNAT.Table;
package body GNAT.CGI is
use Ada;
Valid_Environment : Boolean := True;
-- This boolean will be set to False if the initialization was not
-- completed correctly. It must be set to true there because the
-- Initialize routine (called during elaboration) will use some of the
-- services exported by this unit.
Current_Method : Method_Type;
-- This is the current method used to pass CGI parameters.
Header_Sent : Boolean := False;
-- Will be set to True when the header will be sent.
-- Key/Value table declaration
type String_Access is access String;
type Key_Value is record
Key : String_Access;
Value : String_Access;
end record;
package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
-----------------------
-- Local subprograms --
-----------------------
procedure Check_Environment;
pragma Inline (Check_Environment);
-- This procedure will raise Data_Error if Valid_Environment is False.
procedure Initialize;
-- Initialize CGI package by reading the runtime environment. This
-- procedure is called during elaboration. All exceptions raised during
-- this procedure are deferred.
--------------------
-- Argument_Count --
--------------------
function Argument_Count return Natural is
begin
Check_Environment;
return Key_Value_Table.Last;
end Argument_Count;
-----------------------
-- Check_Environment --
-----------------------
procedure Check_Environment is
begin
if not Valid_Environment then
raise Data_Error;
end if;
end Check_Environment;
------------
-- Decode --
------------
function Decode (S : String) return String is
Result : String (S'Range);
K : Positive := S'First;
J : Positive := Result'First;
begin
while K <= S'Last loop
if K + 2 <= S'Last
and then S (K) = '%'
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
then
-- Here we have '%HH' which is an encoded character where 'HH' is
-- the character number in hexadecimal.
Result (J) := Character'Val
(Natural'Value ("16#" & S (K + 1 .. K + 2) & '#'));
K := K + 3;
else
Result (J) := S (K);
K := K + 1;
end if;
J := J + 1;
end loop;
return Result (Result'First .. J - 1);
end Decode;
-------------------------
-- For_Every_Parameter --
-------------------------
procedure For_Every_Parameter is
Quit : Boolean;
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
Quit := False;
Action (Key_Value_Table.Table (K).Key.all,
Key_Value_Table.Table (K).Value.all,
K,
Quit);
exit when Quit;
end loop;
end For_Every_Parameter;
----------------
-- Initialize --
----------------
procedure Initialize is
Request_Method : constant String :=
Characters.Handling.To_Upper
(Metavariable (CGI.Request_Method));
procedure Initialize_GET;
-- Read CGI parameters for a GET method. In this case the parameters
-- are passed into QUERY_STRING environment variable.
procedure Initialize_POST;
-- Read CGI parameters for a POST method. In this case the parameters
-- are passed with the standard input. The total number of characters
-- for the data is passed in CONTENT_LENGTH environment variable.
procedure Set_Parameter_Table (Data : String);
-- Parse the parameter data and set the parameter table.
--------------------
-- Initialize_GET --
--------------------
procedure Initialize_GET is
Data : constant String := Metavariable (Query_String);
begin
Current_Method := Get;
if Data /= "" then
Set_Parameter_Table (Data);
end if;
end Initialize_GET;
---------------------
-- Initialize_POST --
---------------------
procedure Initialize_POST is
Content_Length : constant Natural :=
Natural'Value (Metavariable (CGI.Content_Length));
Data : String (1 .. Content_Length);
begin
Current_Method := Post;
if Content_Length /= 0 then
Text_IO.Get (Data);
Set_Parameter_Table (Data);
end if;
end Initialize_POST;
-------------------------
-- Set_Parameter_Table --
-------------------------
procedure Set_Parameter_Table (Data : String) is
procedure Add_Parameter (K : Positive; P : String);
-- Add a single parameter into the table at index K. The parameter
-- format is "key=value".
Count : constant Positive :=
1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&"));
-- Count is the number of parameters in the string. Parameters are
-- separated by ampersand character.
Index : Positive := Data'First;
Amp : Natural;
-------------------
-- Add_Parameter --
-------------------
procedure Add_Parameter (K : Positive; P : String) is
Equal : constant Natural := Strings.Fixed.Index (P, "=");
begin
if Equal = 0 then
raise Data_Error;
else
Key_Value_Table.Table (K) :=
Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
new String'(Decode (P (Equal + 1 .. P'Last))));
end if;
end Add_Parameter;
-- Start of processing for Set_Parameter_Table
begin
Key_Value_Table.Set_Last (Count);
for K in 1 .. Count - 1 loop
Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
Add_Parameter (K, Data (Index .. Amp - 1));
Index := Amp + 1;
end loop;
-- add last parameter
Add_Parameter (Count, Data (Index .. Data'Last));
end Set_Parameter_Table;
-- Start of processing for Initialize
begin
if Request_Method = "GET" then
Initialize_GET;
elsif Request_Method = "POST" then
Initialize_POST;
else
Valid_Environment := False;
end if;
exception
when others =>
-- If we have an exception during initialization of this unit we
-- just declare it invalid.
Valid_Environment := False;
end Initialize;
---------
-- Key --
---------
function Key (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Key.all;
else
raise Parameter_Not_Found;
end if;
end Key;
----------------
-- Key_Exists --
----------------
function Key_Exists (Key : String) return Boolean is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return True;
end if;
end loop;
return False;
end Key_Exists;
------------------
-- Metavariable --
------------------
function Metavariable
(Name : Metavariable_Name;
Required : Boolean := False) return String
is
function Get_Environment (Variable_Name : String) return String;
-- Returns the environment variable content.
---------------------
-- Get_Environment --
---------------------
function Get_Environment (Variable_Name : String) return String is
Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
Result : constant String := Value.all;
begin
OS_Lib.Free (Value);
return Result;
end Get_Environment;
Result : constant String :=
Get_Environment (Metavariable_Name'Image (Name));
-- Start of processing for Metavariable
begin
Check_Environment;
if Result = "" and then Required then
raise Parameter_Not_Found;
else
return Result;
end if;
end Metavariable;
-------------------------
-- Metavariable_Exists --
-------------------------
function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
begin
Check_Environment;
if Metavariable (Name) = "" then
return False;
else
return True;
end if;
end Metavariable_Exists;
------------
-- Method --
------------
function Method return Method_Type is
begin
Check_Environment;
return Current_Method;
end Method;
--------
-- Ok --
--------
function Ok return Boolean is
begin
return Valid_Environment;
end Ok;
----------------
-- Put_Header --
----------------
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False)
is
begin
if Header_Sent = False or else Force then
Check_Environment;
Text_IO.Put_Line (Header);
Text_IO.New_Line;
Header_Sent := True;
end if;
end Put_Header;
---------
-- URL --
---------
function URL return String is
function Exists_And_Not_80 (Server_Port : String) return String;
-- Returns ':' & Server_Port if Server_Port is not "80" and the empty
-- string otherwise (80 is the default sever port).
-----------------------
-- Exists_And_Not_80 --
-----------------------
function Exists_And_Not_80 (Server_Port : String) return String is
begin
if Server_Port = "80" then
return "";
else
return ':' & Server_Port;
end if;
end Exists_And_Not_80;
-- Start of processing for URL
begin
Check_Environment;
return "http://"
& Metavariable (Server_Name)
& Exists_And_Not_80 (Metavariable (Server_Port))
& Metavariable (Script_Name);
end URL;
-----------
-- Value --
-----------
function Value
(Key : String;
Required : Boolean := False)
return String
is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return Key_Value_Table.Table (K).Value.all;
end if;
end loop;
if Required then
raise Parameter_Not_Found;
else
return "";
end if;
end Value;
-----------
-- Value --
-----------
function Value (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Value.all;
else
raise Parameter_Not_Found;
end if;
end Value;
begin
Initialize;
end GNAT.CGI;

260
gcc/ada/g-cgi.ads Normal file
View File

@ -0,0 +1,260 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a package to interface a GNAT program with a Web server via the
-- Common Gateway Interface (CGI).
-- Other related packages are:
-- GNAT.CGI.Cookie which deal with Web HTTP Cookies.
-- GNAT.CGI.Debug which output complete CGI runtime environment
-- Basically this package parse the CGI parameter which are a set of key/value
-- pairs. It builds a table whose index is the key and provides some services
-- to deal with this table.
-- Example:
-- Consider the following simple HTML form to capture a client name:
-- <!DOCTYPE HTML PUBLIC "-//W3C//DTD W3 HTML 3.2//EN">
-- <html>
-- <head>
-- <title>My Web Page</title>
-- </head>
-- <body>
-- <form action="/cgi-bin/new_client" method="POST">
-- <input type=text name=client_name>
-- <input type=submit name="Enter">
-- </form>
-- </body>
-- </html>
-- The following program will retrieve the client's name:
-- with GNAT.CGI;
-- procedure New_Client is
-- use GNAT;
-- procedure Add_Client_To_Database (Name : in String) is
-- begin
-- ...
-- end Add_Client_To_Database;
-- begin
-- -- Check that we have 2 arguments (there is two inputs tag in
-- -- the HTML form) and that one of them is called "client_name".
-- if CGI.Argument_Count = 2
-- and the CGI.Key_Exists ("client_name")
-- then
-- Add_Client_To_Database (CGI.Value ("client_name"));
-- end if;
-- ...
-- CGI.Put_Header;
-- Text_IO.Put_Line ("<html><body>< ... Ok ... >");
-- exception
-- when CGI.Data_Error =>
-- CGI.Put_Header ("Location: /htdocs/error.html");
-- -- This returns the address of a Web page to be displayed
-- -- using a "Location:" header style.
-- end New_Client;
-- Note that the names in this package interface have been designed so that
-- they read nicely with the CGI prefix. The recommended style is to avoid
-- a use clause for GNAT.CGI, but to include a use clause for GNAT.
-- This package builds up a table of CGI parameters whose memory is not
-- released. A CGI program is expected to be a short lived program and
-- so it is adequate to have the underlying OS free the program on exit.
package GNAT.CGI is
Data_Error : exception;
-- This is raised when there is a problem with the CGI protocol. Either
-- the data could not be retrieved or the CGI environment is invalid.
--
-- The package will initialize itself by parsing the runtime CGI
-- environment during elaboration but we do not want to raise an
-- exception at this time, so the exception Data_Error is deferred
-- and will be raised when calling any services below (except for Ok).
Parameter_Not_Found : exception;
-- This exception is raised when a specific parameter is not found.
Default_Header : constant String := "Content-type: text/html";
-- This is the default header returned by Put_Header. If the CGI program
-- returned data is not an HTML page, this header must be change to a
-- valid MIME type.
type Method_Type is (Get, Post);
-- The method used to pass parameter from the Web client to the
-- server. With the GET method parameters are passed via the command
-- line, with the POST method parameters are passed via environment
-- variables. Others methods are not supported by this implementation.
type Metavariable_Name is
(Auth_Type,
Content_Length,
Content_Type,
Document_Root, -- Web server dependant
Gateway_Interface,
HTTP_Accept,
HTTP_Accept_Encoding,
HTTP_Accept_Language,
HTTP_Connection,
HTTP_Cookie,
HTTP_Extension,
HTTP_From,
HTTP_Host,
HTTP_Referer,
HTTP_User_Agent,
Path,
Path_Info,
Path_Translated,
Query_String,
Remote_Addr,
Remote_Host,
Remote_Port, -- Web server dependant
Remote_Ident,
Remote_User,
Request_Method,
Request_URI, -- Web server dependant
Script_Filename, -- Web server dependant
Script_Name,
Server_Addr, -- Web server dependant
Server_Admin, -- Web server dependant
Server_Name,
Server_Port,
Server_Protocol,
Server_Signature, -- Web server dependant
Server_Software);
-- CGI metavariables that are set by the Web server during program
-- execution. All these variables are part of the restricted CGI runtime
-- environment and can be read using Metavariable service. The detailed
-- meanings of these metavariables are out of the scope of this
-- description. Please refer to http://www.w3.org/CGI/ for a description
-- of the CGI specification. Some metavariables are Web server dependant
-- and are not described in the cited document.
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False);
-- Output standard CGI header by default. The header string is followed by
-- an empty line. This header must be the first answer sent back to the
-- server. Do nothing if this function has already been called and Force
-- is False.
function Ok return Boolean;
-- Returns True if the CGI environment is valid and False otherwise.
-- Every service used when the CGI environment is not valid will raise
-- the exception Data_Error.
function Method return Method_Type;
-- Returns the method used to call the CGI.
function Metavariable
(Name : Metavariable_Name;
Required : Boolean := False)
return String;
-- Returns parameter Name value. Returns the null string if Name
-- environment variable is not defined or raises Data_Error if
-- Required is set to True.
function Metavariable_Exists (Name : Metavariable_Name) return Boolean;
-- Returns True if the environment variable Name is defined in
-- the CGI runtime environment and False otherwise.
function URL return String;
-- Returns the URL used to call this script without the parameters.
-- The URL form is: http://<server_name>[:<server_port>]<script_name>
function Argument_Count return Natural;
-- Returns the number of parameters passed to the client. This is the
-- number of input tags in a form or the number of parameters passed to
-- the CGI via the command line.
---------------------------------------------------
-- Services to retrieve key/value CGI parameters --
---------------------------------------------------
function Value
(Key : String;
Required : Boolean := False)
return String;
-- Returns the parameter value associated to the parameter named Key.
-- If parameter does not exist, returns an empty string if Required
-- is False and raises the exception Parameter_Not_Found otherwise.
function Value (Position : Positive) return String;
-- Returns the parameter value associated with the CGI parameter number
-- Position. Raises Parameter_Not_Found if there is no such parameter
-- (i.e. Position > Argument_Count)
function Key_Exists (Key : String) return Boolean;
-- Returns True if the parameter named Key existx and False otherwise.
function Key (Position : Positive) return String;
-- Returns the parameter key associated with the CGI parameter number
-- Position. Raises the exception Parameter_Not_Found if there is no
-- such parameter (i.e. Position > Argument_Count)
generic
with procedure
Action
(Key : String;
Value : String;
Position : Positive;
Quit : in out Boolean);
procedure For_Every_Parameter;
-- Iterate through all existing key/value pairs and call the Action
-- supplied procedure. The Key and Value are set appropriately, Position
-- is the parameter order in the list, Quit is set to True by default.
-- Quit can be set to False to control the iterator termination.
private
function Decode (S : String) return String;
-- Decode Web string S. A string when passed to a CGI is encoded,
-- this function will decode the string to return the original
-- string's content. Every triplet of the form %HH (where H is an
-- hexadecimal number) is translated into the character such that:
-- Hex (Character'Pos (C)) = HH.
end GNAT.CGI;

405
gcc/ada/g-cgicoo.adb Normal file
View File

@ -0,0 +1,405 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . C O O K I E --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc.
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with GNAT.Table;
package body GNAT.CGI.Cookie is
use Ada;
Valid_Environment : Boolean := False;
-- This boolean will be set to True if the initialization was fine.
Header_Sent : Boolean := False;
-- Will be set to True when the header will be sent.
-- Cookie data that have been added.
type String_Access is access String;
type Cookie_Data is record
Key : String_Access;
Value : String_Access;
Comment : String_Access;
Domain : String_Access;
Max_Age : Natural;
Path : String_Access;
Secure : Boolean := False;
end record;
type Key_Value is record
Key, Value : String_Access;
end record;
package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
-- This is the table to keep all cookies to be sent back to the server.
package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
-- This is the table to keep all cookies received from the server.
procedure Check_Environment;
pragma Inline (Check_Environment);
-- This procedure will raise Data_Error if Valid_Environment is False.
procedure Initialize;
-- Initialize CGI package by reading the runtime environment. This
-- procedure is called during elaboration. All exceptions raised during
-- this procedure are deferred.
-----------------------
-- Check_Environment --
-----------------------
procedure Check_Environment is
begin
if not Valid_Environment then
raise Data_Error;
end if;
end Check_Environment;
-----------
-- Count --
-----------
function Count return Natural is
begin
return Key_Value_Table.Last;
end Count;
------------
-- Exists --
------------
function Exists (Key : String) return Boolean is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return True;
end if;
end loop;
return False;
end Exists;
----------------------
-- For_Every_Cookie --
----------------------
procedure For_Every_Cookie is
Quit : Boolean;
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
Quit := False;
Action (Key_Value_Table.Table (K).Key.all,
Key_Value_Table.Table (K).Value.all,
K,
Quit);
exit when Quit;
end loop;
end For_Every_Cookie;
----------------
-- Initialize --
----------------
procedure Initialize is
HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
procedure Set_Parameter_Table (Data : String);
-- Parse Data and insert information in Key_Value_Table.
-------------------------
-- Set_Parameter_Table --
-------------------------
procedure Set_Parameter_Table (Data : String) is
procedure Add_Parameter (K : Positive; P : String);
-- Add a single parameter into the table at index K. The parameter
-- format is "key=value".
Count : constant Positive
:= 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
-- Count is the number of parameters in the string. Parameters are
-- separated by ampersand character.
Index : Positive := Data'First;
Sep : Natural;
-------------------
-- Add_Parameter --
-------------------
procedure Add_Parameter (K : Positive; P : String) is
Equal : constant Natural := Strings.Fixed.Index (P, "=");
begin
if Equal = 0 then
raise Data_Error;
else
Key_Value_Table.Table (K) :=
Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
new String'(Decode (P (Equal + 1 .. P'Last))));
end if;
end Add_Parameter;
begin
Key_Value_Table.Set_Last (Count);
for K in 1 .. Count - 1 loop
Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
Add_Parameter (K, Data (Index .. Sep - 1));
Index := Sep + 2;
end loop;
-- add last parameter
Add_Parameter (Count, Data (Index .. Data'Last));
end Set_Parameter_Table;
begin
if HTTP_COOKIE /= "" then
Set_Parameter_Table (HTTP_COOKIE);
end if;
Valid_Environment := True;
exception
when others =>
Valid_Environment := False;
end Initialize;
---------
-- Key --
---------
function Key (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Key.all;
else
raise Cookie_Not_Found;
end if;
end Key;
--------
-- Ok --
--------
function Ok return Boolean is
begin
return Valid_Environment;
end Ok;
----------------
-- Put_Header --
----------------
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False)
is
procedure Output_Cookies;
-- Iterate through the list of cookies to be sent to the server
-- and output them.
--------------------
-- Output_Cookies --
--------------------
procedure Output_Cookies is
procedure Output_One_Cookie
(Key : String;
Value : String;
Comment : String;
Domain : String;
Max_Age : Natural;
Path : String;
Secure : Boolean);
-- Output one cookie in the CGI header.
-----------------------
-- Output_One_Cookie --
-----------------------
procedure Output_One_Cookie
(Key : String;
Value : String;
Comment : String;
Domain : String;
Max_Age : Natural;
Path : String;
Secure : Boolean)
is
begin
Text_IO.Put ("Set-Cookie: ");
Text_IO.Put (Key & '=' & Value);
if Comment /= "" then
Text_IO.Put ("; Comment=" & Comment);
end if;
if Domain /= "" then
Text_IO.Put ("; Domain=" & Domain);
end if;
if Max_Age /= Natural'Last then
Text_IO.Put ("; Max-Age=");
Integer_Text_IO.Put (Max_Age, Width => 0);
end if;
if Path /= "" then
Text_IO.Put ("; Path=" & Path);
end if;
if Secure then
Text_IO.Put ("; Secure");
end if;
Text_IO.New_Line;
end Output_One_Cookie;
-- Start of processing for Output_Cookies
begin
for C in 1 .. Cookie_Table.Last loop
Output_One_Cookie (Cookie_Table.Table (C).Key.all,
Cookie_Table.Table (C).Value.all,
Cookie_Table.Table (C).Comment.all,
Cookie_Table.Table (C).Domain.all,
Cookie_Table.Table (C).Max_Age,
Cookie_Table.Table (C).Path.all,
Cookie_Table.Table (C).Secure);
end loop;
end Output_Cookies;
-- Start of processing for Put_Header
begin
if Header_Sent = False or else Force then
Check_Environment;
Text_IO.Put_Line (Header);
Output_Cookies;
Text_IO.New_Line;
Header_Sent := True;
end if;
end Put_Header;
---------
-- Set --
---------
procedure Set
(Key : String;
Value : String;
Comment : String := "";
Domain : String := "";
Max_Age : Natural := Natural'Last;
Path : String := "/";
Secure : Boolean := False) is
begin
Cookie_Table.Increment_Last;
Cookie_Table.Table (Cookie_Table.Last) :=
Cookie_Data'(new String'(Key),
new String'(Value),
new String'(Comment),
new String'(Domain),
Max_Age,
new String'(Path),
Secure);
end Set;
-----------
-- Value --
-----------
function Value
(Key : String;
Required : Boolean := False)
return String
is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return Key_Value_Table.Table (K).Value.all;
end if;
end loop;
if Required then
raise Cookie_Not_Found;
else
return "";
end if;
end Value;
function Value (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Value.all;
else
raise Cookie_Not_Found;
end if;
end Value;
-- Elaboration code for package
begin
-- Initialize unit by reading the HTTP_COOKIE metavariable and fill
-- Key_Value_Table structure.
Initialize;
end GNAT.CGI.Cookie;

124
gcc/ada/g-cgicoo.ads Normal file
View File

@ -0,0 +1,124 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . C O O K I E --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a package to interface a GNAT program with a Web server via the
-- Common Gateway Interface (CGI). It exports services to deal with Web
-- cookies (piece of information kept in the Web client software).
-- The complete CGI Cookie specification can be found in the RFC2109 at:
-- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
-- This package builds up data tables whose memory is not released.
-- A CGI program is expected to be a short lived program and so it
-- is adequate to have the underlying OS free the program on exit.
package GNAT.CGI.Cookie is
-- The package will initialize itself by parsing the HTTP_Cookie runtime
-- CGI environment variable during elaboration but we do not want to raise
-- an exception at this time, so the exception Data_Error is deferred and
-- will be raised when calling any services below (except for Ok).
Cookie_Not_Found : exception;
-- This exception is raised when a specific parameter is not found.
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False);
-- Output standard CGI header by default. This header must be returned
-- back to the server at the very beginning and will be output only for
-- the first call to Put_Header if Force is set to False. This procedure
-- also outputs the Cookies that have been defined. If the program uses
-- the GNAT.CGI.Put_Header service, cookies will not be set.
--
-- Cookies are passed back to the server in the header, the format is:
--
-- Set-Cookie: <key>=<value>; comment=<comment>; domain=<domain>;
-- max_age=<max_age>; path=<path>[; secured]
function Ok return Boolean;
-- Returns True if the CGI cookie environment is valid and False
-- otherwise. Every service used when the CGI environment is not valid
-- will raise the exception Data_Error.
function Count return Natural;
-- Returns the number of cookies received by the CGI.
function Value
(Key : String;
Required : Boolean := False)
return String;
-- Returns the cookie value associated with the cookie named Key. If
-- cookie does not exist, returns an empty string if Required is
-- False and raises the exception Cookie_Not_Found otherwise.
function Value (Position : Positive) return String;
-- Returns the value associated with the cookie number Position
-- of the CGI. It raises Cookie_Not_Found if there is no such
-- cookie (i.e. Position > Count)
function Exists (Key : String) return Boolean;
-- Returns True if the cookie named Key exist and False otherwise.
function Key (Position : Positive) return String;
-- Returns the key associated with the cookie number Position of
-- the CGI. It raises Cookie_Not_Found if there is no such cookie
-- (i.e. Position > Count)
procedure Set
(Key : String;
Value : String;
Comment : String := "";
Domain : String := "";
Max_Age : Natural := Natural'Last;
Path : String := "/";
Secure : Boolean := False);
-- Add a cookie to the list of cookies. This will be sent back
-- to the server by the Put_Header service above.
generic
with procedure
Action
(Key : String;
Value : String;
Position : Positive;
Quit : in out Boolean);
procedure For_Every_Cookie;
-- Iterate through all cookies received from the server and call
-- the Action supplied procedure. The Key, Value parameters are set
-- appropriately, Position is the cookie order in the list, Quit is set to
-- True by default. Quit can be set to False to control the iterator
-- termination.
end GNAT.CGI.Cookie;

332
gcc/ada/g-cgideb.adb Normal file
View File

@ -0,0 +1,332 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . D E B U G --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Unbounded;
package body GNAT.CGI.Debug is
use Ada.Strings.Unbounded;
--
-- Define the abstract type which act as a template for all debug IO mode.
-- To create a new IO mode you must:
-- 1. create a new package spec
-- 2. create a new type derived from IO.Format
-- 3. implement all the abstract rountines in IO
--
package IO is
type Format is abstract tagged null record;
function Output (Mode : in Format'Class) return String;
function Variable
(Mode : Format;
Name : String;
Value : String)
return String
is abstract;
-- Returns variable Name and its associated value.
function New_Line
(Mode : Format)
return String
is abstract;
-- Returns a new line such as this concatenated between two strings
-- will display the strings on two lines.
function Title
(Mode : Format;
Str : String)
return String
is abstract;
-- Returns Str as a Title. A title must be alone and centered on a
-- line. Next output will be on the following line.
function Header
(Mode : Format;
Str : String)
return String
is abstract;
-- Returns Str as an Header. An header must be alone on its line. Next
-- output will be on the following line.
end IO;
--
-- IO for HTML mode
--
package HTML_IO is
-- see IO for comments about these routines.
type Format is new IO.Format with null record;
function Variable
(IO : Format;
Name : String;
Value : String)
return String;
function New_Line (IO : in Format) return String;
function Title (IO : in Format; Str : in String) return String;
function Header (IO : in Format; Str : in String) return String;
end HTML_IO;
--
-- IO for plain text mode
--
package Text_IO is
-- See IO for comments about these routines
type Format is new IO.Format with null record;
function Variable
(IO : Format;
Name : String;
Value : String)
return String;
function New_Line (IO : in Format) return String;
function Title (IO : in Format; Str : in String) return String;
function Header (IO : in Format; Str : in String) return String;
end Text_IO;
--------------
-- Debug_IO --
--------------
package body IO is
------------
-- Output --
------------
function Output (Mode : in Format'Class) return String is
Result : Unbounded_String;
begin
Result := Result
& Title (Mode, "CGI complete runtime environment");
Result := Result
& Header (Mode, "CGI parameters:")
& New_Line (Mode);
for K in 1 .. Argument_Count loop
Result := Result
& Variable (Mode, Key (K), Value (K))
& New_Line (Mode);
end loop;
Result := Result
& New_Line (Mode)
& Header (Mode, "CGI environment variables (Metavariables):")
& New_Line (Mode);
for P in Metavariable_Name'Range loop
if Metavariable_Exists (P) then
Result := Result
& Variable (Mode,
Metavariable_Name'Image (P),
Metavariable (P))
& New_Line (Mode);
end if;
end loop;
return To_String (Result);
end Output;
end IO;
-------------
-- HTML_IO --
-------------
package body HTML_IO is
NL : constant String := (1 => ASCII.LF);
function Bold (S : in String) return String;
-- Returns S as an HTML bold string.
function Italic (S : in String) return String;
-- Returns S as an HTML italic string.
----------
-- Bold --
----------
function Bold (S : in String) return String is
begin
return "<b>" & S & "</b>";
end Bold;
------------
-- Header --
------------
function Header (IO : in Format; Str : in String) return String is
begin
return "<h2>" & Str & "</h2>" & NL;
end Header;
------------
-- Italic --
------------
function Italic (S : in String) return String is
begin
return "<i>" & S & "</i>";
end Italic;
--------------
-- New_Line --
--------------
function New_Line (IO : in Format) return String is
begin
return "<br>" & NL;
end New_Line;
-----------
-- Title --
-----------
function Title (IO : in Format; Str : in String) return String is
begin
return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
end Title;
--------------
-- Variable --
--------------
function Variable
(IO : Format;
Name : String;
Value : String)
return String
is
begin
return Bold (Name) & " = " & Italic (Value);
end Variable;
end HTML_IO;
-------------
-- Text_IO --
-------------
package body Text_IO is
------------
-- Header --
------------
function Header (IO : in Format; Str : in String) return String is
begin
return "*** " & Str & New_Line (IO);
end Header;
--------------
-- New_Line --
--------------
function New_Line (IO : in Format) return String is
begin
return String'(1 => ASCII.LF);
end New_Line;
-----------
-- Title --
-----------
function Title (IO : in Format; Str : in String) return String is
Spaces : constant Natural := (80 - Str'Length) / 2;
Indent : constant String (1 .. Spaces) := (others => ' ');
begin
return Indent & Str & New_Line (IO);
end Title;
--------------
-- Variable --
--------------
function Variable
(IO : Format;
Name : String;
Value : String)
return String
is
begin
return " " & Name & " = " & Value;
end Variable;
end Text_IO;
-----------------
-- HTML_Output --
-----------------
function HTML_Output return String is
HTML : HTML_IO.Format;
begin
return IO.Output (Mode => HTML);
end HTML_Output;
-----------------
-- Text_Output --
-----------------
function Text_Output return String is
Text : Text_IO.Format;
begin
return IO.Output (Mode => Text);
end Text_Output;
end GNAT.CGI.Debug;

50
gcc/ada/g-cgideb.ads Normal file
View File

@ -0,0 +1,50 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C G I . D E B U G --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a package to help debugging CGI (Common Gateway Interface)
-- programs written in Ada.
package GNAT.CGI.Debug is
-- Both functions below output all possible CGI parameters set. These
-- are the form field and all CGI environment variables which make the
-- CGI environment at runtime.
function Text_Output return String;
-- Returns a plain text version of the CGI runtime environment
function HTML_Output return String;
-- Returns an HTML version of the CGI runtime environment
end GNAT.CGI.Debug;

612
gcc/ada/g-comlin.adb Normal file
View File

@ -0,0 +1,612 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C O M M A N D _ L I N E --
-- --
-- B o d y --
-- --
-- $Revision: 1.21 $
-- --
-- Copyright (C) 1999-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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Command_Line;
package body GNAT.Command_Line is
package CL renames Ada.Command_Line;
type Section_Number is new Natural range 0 .. 65534;
for Section_Number'Size use 16;
type Parameter_Type is
record
Arg_Num : Positive;
First : Positive;
Last : Positive;
end record;
The_Parameter : Parameter_Type;
The_Switch : Parameter_Type;
-- This type and this variable are provided to store the current switch
-- and parameter
type Is_Switch_Type is array (1 .. CL.Argument_Count) of Boolean;
pragma Pack (Is_Switch_Type);
Is_Switch : Is_Switch_Type := (others => False);
-- Indicates wich arguments on the command line are considered not be
-- switches or parameters to switches (this leaves e.g. the filenames...)
type Section_Type is array (1 .. CL.Argument_Count + 1) of Section_Number;
pragma Pack (Section_Type);
Section : Section_Type := (others => 1);
-- Contains the number of the section associated with the current
-- switch. If this number is 0, then it is a section delimiter, which
-- is never returns by GetOpt.
-- The last element of this array is set to 0 to avoid the need to test for
-- if we have reached the end of the command line in loops.
Current_Argument : Natural := 1;
-- Number of the current argument parsed on the command line
Current_Index : Natural := 1;
-- Index in the current argument of the character to be processed
Current_Section : Section_Number := 1;
Expansion_It : aliased Expansion_Iterator;
-- When Get_Argument is expanding a file name, this is the iterator used
In_Expansion : Boolean := False;
-- True if we are expanding a file
Switch_Character : Character := '-';
-- The character at the beginning of the command line arguments,
-- indicating the beginning of a switch
Stop_At_First : Boolean := False;
-- If it is True then Getopt stops at the first non-switch argument
procedure Set_Parameter
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
Last : Positive);
pragma Inline (Set_Parameter);
-- Set the parameter that will be returned by Parameter below
function Goto_Next_Argument_In_Section return Boolean;
-- Go to the next argument on the command line. If we are at the end
-- of the current section, we want to make sure there is no other
-- identical section on the command line (there might be multiple
-- instances of -largs).
-- Return True if there as another argument, False otherwise
---------------
-- Expansion --
---------------
function Expansion (Iterator : Expansion_Iterator) return String is
use GNAT.Directory_Operations;
type Pointer is access all Expansion_Iterator;
S : String (1 .. 1024);
Last : Natural;
It : Pointer := Iterator'Unrestricted_Access;
begin
loop
Read (It.Dir, S, Last);
if Last = 0 then
Close (It.Dir);
return String'(1 .. 0 => ' ');
end if;
if GNAT.Regexp.Match (S (1 .. Last), Iterator.Regexp) then
return S (1 .. Last);
end if;
end loop;
return String'(1 .. 0 => ' ');
end Expansion;
-----------------
-- Full_Switch --
-----------------
function Full_Switch return String is
begin
return CL.Argument (The_Switch.Arg_Num)
(The_Switch.First .. The_Switch.Last);
end Full_Switch;
------------------
-- Get_Argument --
------------------
function Get_Argument (Do_Expansion : Boolean := False) return String is
Total : constant Natural := CL.Argument_Count;
begin
if In_Expansion then
declare
S : String := Expansion (Expansion_It);
begin
if S'Length /= 0 then
return S;
else
In_Expansion := False;
end if;
end;
end if;
if Current_Argument > Total then
-- If this is the first time this function is called
if Current_Index = 1 then
Current_Argument := 1;
while Current_Argument <= CL.Argument_Count
and then Section (Current_Argument) /= Current_Section
loop
Current_Argument := Current_Argument + 1;
end loop;
else
return String'(1 .. 0 => ' ');
end if;
elsif Section (Current_Argument) = 0 then
while Current_Argument <= CL.Argument_Count
and then Section (Current_Argument) /= Current_Section
loop
Current_Argument := Current_Argument + 1;
end loop;
end if;
Current_Index := 2;
while Current_Argument <= Total
and then Is_Switch (Current_Argument)
loop
Current_Argument := Current_Argument + 1;
end loop;
if Current_Argument > Total then
return String'(1 .. 0 => ' ');
end if;
if Section (Current_Argument) = 0 then
return Get_Argument (Do_Expansion);
end if;
Current_Argument := Current_Argument + 1;
-- Could it be a file name with wild cards to expand ?
if Do_Expansion then
declare
Arg : String renames CL.Argument (Current_Argument - 1);
Index : Positive := Arg'First;
begin
while Index <= Arg'Last loop
if Arg (Index) = '*'
or else Arg (Index) = '?'
or else Arg (Index) = '['
then
In_Expansion := True;
Start_Expansion (Expansion_It, Arg);
return Get_Argument (Do_Expansion);
end if;
Index := Index + 1;
end loop;
end;
end if;
return CL.Argument (Current_Argument - 1);
end Get_Argument;
------------
-- Getopt --
------------
function Getopt (Switches : String) return Character is
Dummy : Boolean;
begin
-- If we have finished to parse the current command line item (there
-- might be multiple switches in a single item), then go to the next
-- element
if Current_Argument > CL.Argument_Count
or else (Current_Index > CL.Argument (Current_Argument)'Last
and then not Goto_Next_Argument_In_Section)
then
return ASCII.NUL;
end if;
-- If we are on a new item, test if this might be a switch
if Current_Index = 1 then
if CL.Argument (Current_Argument)(1) /= Switch_Character then
if Switches (Switches'First) = '*' then
Set_Parameter (The_Switch,
Arg_Num => Current_Argument,
First => 1,
Last => CL.Argument (Current_Argument)'Last);
Is_Switch (Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section;
return '*';
end if;
if Stop_At_First then
Current_Argument := Positive'Last;
return ASCII.NUL;
elsif not Goto_Next_Argument_In_Section then
return ASCII.NUL;
else
return Getopt (Switches);
end if;
end if;
Current_Index := 2;
Is_Switch (Current_Argument) := True;
end if;
declare
Arg : String renames CL.Argument (Current_Argument);
Index_Switches : Natural := 0;
Max_Length : Natural := 0;
Index : Natural := Switches'First;
Length : Natural := 1;
End_Index : Natural;
begin
while Index <= Switches'Last loop
-- Search the length of the parameter at this position in Switches
Length := Index;
while Length <= Switches'Last
and then Switches (Length) /= ' '
loop
Length := Length + 1;
end loop;
if (Switches (Length - 1) = ':'
or else Switches (Length - 1) = '?'
or else Switches (Length - 1) = '!')
and then Length > Index + 1
then
Length := Length - 1;
end if;
-- If it is the one we searched, it may be a candidate
if Current_Index + Length - 1 - Index <= Arg'Last
and then
Switches (Index .. Length - 1) =
Arg (Current_Index .. Current_Index + Length - 1 - Index)
and then Length - Index > Max_Length
then
Index_Switches := Index;
Max_Length := Length - Index;
end if;
-- Look for the next switch in Switches
while Index <= Switches'Last
and then Switches (Index) /= ' ' loop
Index := Index + 1;
end loop;
Index := Index + 1;
end loop;
End_Index := Current_Index + Max_Length - 1;
-- If the switch is not accepted, skip it, unless we had a '*' in
-- Switches
if Index_Switches = 0 then
if Switches (Switches'First) = '*' then
Set_Parameter (The_Switch,
Arg_Num => Current_Argument,
First => 1,
Last => CL.Argument (Current_Argument)'Last);
Is_Switch (Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section;
return '*';
end if;
Set_Parameter (The_Switch,
Arg_Num => Current_Argument,
First => Current_Index,
Last => Current_Index);
Current_Index := Current_Index + 1;
raise Invalid_Switch;
end if;
Set_Parameter (The_Switch,
Arg_Num => Current_Argument,
First => Current_Index,
Last => End_Index);
-- If switch needs an argument
if Index_Switches + Max_Length <= Switches'Last then
case Switches (Index_Switches + Max_Length) is
when ':' =>
if End_Index < Arg'Last then
Set_Parameter (The_Parameter,
Arg_Num => Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
Dummy := Goto_Next_Argument_In_Section;
elsif Section (Current_Argument + 1) /= 0 then
Set_Parameter
(The_Parameter,
Arg_Num => Current_Argument + 1,
First => 1,
Last => CL.Argument (Current_Argument + 1)'Last);
Current_Argument := Current_Argument + 1;
Is_Switch (Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section;
else
Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
when '!' =>
if End_Index < Arg'Last then
Set_Parameter (The_Parameter,
Arg_Num => Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
Dummy := Goto_Next_Argument_In_Section;
else
Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
when '?' =>
if End_Index < Arg'Last then
Set_Parameter (The_Parameter,
Arg_Num => Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
else
Set_Parameter (The_Parameter,
Arg_Num => Current_Argument,
First => 2,
Last => 1);
end if;
Dummy := Goto_Next_Argument_In_Section;
when others =>
Current_Index := End_Index + 1;
end case;
else
Current_Index := End_Index + 1;
end if;
return Switches (Index_Switches);
end;
end Getopt;
-----------------------------------
-- Goto_Next_Argument_In_Section --
-----------------------------------
function Goto_Next_Argument_In_Section return Boolean is
begin
Current_Index := 1;
Current_Argument := Current_Argument + 1;
if Section (Current_Argument) = 0 then
loop
if Current_Argument > CL.Argument_Count then
return False;
end if;
Current_Argument := Current_Argument + 1;
exit when Section (Current_Argument) = Current_Section;
end loop;
end if;
return True;
end Goto_Next_Argument_In_Section;
------------------
-- Goto_Section --
------------------
procedure Goto_Section (Name : String := "") is
Index : Integer := 1;
begin
In_Expansion := False;
if Name = "" then
Current_Argument := 1;
Current_Index := 1;
Current_Section := 1;
return;
end if;
while Index <= CL.Argument_Count loop
if Section (Index) = 0
and then CL.Argument (Index) = Switch_Character & Name
then
Current_Argument := Index + 1;
Current_Index := 1;
if Current_Argument <= CL.Argument_Count then
Current_Section := Section (Current_Argument);
end if;
return;
end if;
Index := Index + 1;
end loop;
Current_Argument := Positive'Last;
Current_Index := 2; -- so that Get_Argument returns nothing
end Goto_Section;
----------------------------
-- Initialize_Option_Scan --
----------------------------
procedure Initialize_Option_Scan
(Switch_Char : Character := '-';
Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := "")
is
Section_Num : Section_Number := 1;
Section_Index : Integer := Section_Delimiters'First;
Last : Integer;
Delimiter_Found : Boolean;
begin
Current_Argument := 0;
Current_Index := 0;
In_Expansion := False;
Switch_Character := Switch_Char;
Stop_At_First := Stop_At_First_Non_Switch;
-- If we are using sections, we have to preprocess the command line
-- to delimit them. A section can be repeated, so we just give each
-- item on the command line a section number
while Section_Index <= Section_Delimiters'Last loop
Last := Section_Index;
while Last <= Section_Delimiters'Last
and then Section_Delimiters (Last) /= ' '
loop
Last := Last + 1;
end loop;
Delimiter_Found := False;
Section_Num := Section_Num + 1;
for Index in 1 .. CL.Argument_Count loop
if CL.Argument (Index)(1) = Switch_Character
and then CL.Argument (Index) = Switch_Character
& Section_Delimiters (Section_Index .. Last - 1)
then
Section (Index) := 0;
Delimiter_Found := True;
elsif Section (Index) = 0 then
Delimiter_Found := False;
elsif Delimiter_Found then
Section (Index) := Section_Num;
end if;
end loop;
Section_Index := Last + 1;
while Section_Index <= Section_Delimiters'Last
and then Section_Delimiters (Section_Index) = ' '
loop
Section_Index := Section_Index + 1;
end loop;
end loop;
Delimiter_Found := Goto_Next_Argument_In_Section;
end Initialize_Option_Scan;
---------------
-- Parameter --
---------------
function Parameter return String is
begin
if The_Parameter.First > The_Parameter.Last then
return String'(1 .. 0 => ' ');
else
return CL.Argument (The_Parameter.Arg_Num)
(The_Parameter.First .. The_Parameter.Last);
end if;
end Parameter;
-------------------
-- Set_Parameter --
-------------------
procedure Set_Parameter
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
Last : Positive) is
begin
Variable.Arg_Num := Arg_Num;
Variable.First := First;
Variable.Last := Last;
end Set_Parameter;
---------------------
-- Start_Expansion --
---------------------
procedure Start_Expansion
(Iterator : out Expansion_Iterator;
Pattern : String;
Directory : String := "";
Basic_Regexp : Boolean := True)
is
Directory_Separator : Character;
pragma Import (C, Directory_Separator, "__gnat_dir_separator");
begin
if Directory = "" then
GNAT.Directory_Operations.Open
(Iterator.Dir, "." & Directory_Separator);
else
GNAT.Directory_Operations.Open (Iterator.Dir, Directory);
end if;
Iterator.Regexp := GNAT.Regexp.Compile (Pattern, Basic_Regexp, True);
end Start_Expansion;
begin
Section (CL.Argument_Count + 1) := 0;
end GNAT.Command_Line;

272
gcc/ada/g-comlin.ads Normal file
View File

@ -0,0 +1,272 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C O M M A N D _ L I N E --
-- --
-- S p e c --
-- --
-- $Revision: 1.24 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- High level package for command line parsing
-- This package provides an interface to Ada.Command_Line, to do the
-- parsing of command line arguments. Here is a small usage example:
--
-- begin
-- loop
-- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument'
-- when ASCII.NUL => exit;
--
-- when 'a' =>
-- if Full_Switch = "a" then
-- Put_Line ("Got a");
-- else
-- Put_Line ("Got ad");
-- end if;
--
-- when 'b' =>
-- Put_Line ("Got b + " & Parameter);
--
-- when others =>
-- raise Program_Error; -- cannot occur!
-- end case;
-- end loop;
--
-- loop
-- declare
-- S : constant String := Get_Argument (Do_Expansion => True);
-- begin
-- exit when S'Length = 0;
-- Put_Line ("Got " & S);
-- end;
-- end loop;
--
-- exception
-- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch);
-- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch);
-- end;
--
-- A more complicated example would involve the use of sections for the
-- switches, as for instance in gnatmake. These sections are separated by
-- special switches, chosen by the programer. Each section act as a
-- command line of its own.
--
-- begin
-- Initialize_Option_Scan ('-', False, "largs bargs cargs");
-- loop
-- -- same loop as above to get switches and arguments
-- end loop;
--
-- Goto_Section ("bargs");
-- loop
-- -- same loop as above to get switches and arguments
-- -- The supports switches in Get_Opt might be different
-- end loop;
--
-- Goto_Section ("cargs");
-- loop
-- -- same loop as above to get switches and arguments
-- -- The supports switches in Get_Opt might be different
-- end loop;
-- end;
with GNAT.Directory_Operations;
with GNAT.Regexp;
package GNAT.Command_Line is
procedure Initialize_Option_Scan
(Switch_Char : Character := '-';
Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := "");
-- This procedure resets the internal state of the package to prepare
-- to rescan the parameters. It need not (but may be) called before the
-- first use of Getopt, but it must be called if you want to start
-- rescanning the command line parameters from the start. The optional
-- parameter Switch_Char can be used to reset the switch character,
-- e.g. to '/' for use in DOS-like systems. The optional parameter
-- Stop_At_First_Non_Switch indicates if Getopt is to look for switches
-- on the whole command line, or if it has to stop as soon as a
-- non-switch argument is found.
--
-- Example:
--
-- Arguments: my_application file1 -c
--
-- if Stop_At_First_Non_Switch is False, then -c will be considered
-- as a switch (returned by getopt), otherwise it will be considered
-- as a normal argument (returned by Get_Argument).
--
-- if SECTION_DELIMITERS is set, then every following subprogram
-- (Getopt and Get_Argument) will only operate within a section, which
-- is delimited by any of these delimiters or the end of the command line.
--
-- Example:
-- Initialize_Option_Scan ("largs bargs cargs");
--
-- Arguments on command line : my_application -c -bargs -d -e -largs -f
-- This line is made of three section, the first one is the default one
-- and includes only the '-c' switch, the second one is between -bargs
-- and -largs and includes '-d -e' and the last one includes '-f'
procedure Goto_Section (Name : String := "");
-- Change the current section. The next Getopt of Get_Argument will
-- start looking at the beginning of the section. An empty name ("")
-- refers to the first section between the program name and the first
-- section delimiter.
-- If the section does not exist, then Invalid_Section is raised.
function Full_Switch return String;
-- Returns the full name of the last switch found (Getopt only returns
-- the first character)
function Getopt (Switches : String) return Character;
-- This function moves to the next switch on the command line (defined
-- as a switch character followed by a character within Switches,
-- casing being significant). The result returned is the first
-- character of the particular switch located. If there are no more
-- switches in the current section, returns ASCII.NUL. The switches
-- need not be separated by spaces (they can be concatenated if they do
-- not require an argument, e.g. -ab is the same as two separate
-- arguments -a -b).
--
-- Switches is a string of all the possible switches, separated by a
-- space. A switch can be followed by one of the following characters :
--
-- ':' The switch requires a parameter. There can optionally be a space
-- on the command line between the switch and its parameter
-- '!' The switch requires a parameter, but there can be no space on the
-- command line between the switch and its parameter
-- '?' The switch may have an optional parameter. There can no space
-- between the switch and its argument
-- ex/ if Switches has the following value : "a? b"
-- The command line can be :
-- -afoo : -a switch with 'foo' parameter
-- -a foo : -a switch and another element on the
-- command line 'foo', returned by Get_Argument
--
-- Example: if Switches is "-a: -aO:", you can have the following
-- command lines :
-- -aarg : 'a' switch with 'arg' parameter
-- -a arg : 'a' switch with 'arg' parameter
-- -aOarg : 'aO' switch with 'arg' parameter
-- -aO arg : 'aO' switch with 'arg' parameter
--
-- Example:
--
-- Getopt ("a b: ac ad?")
--
-- accept either 'a' or 'ac' with no argument,
-- accept 'b' with a required argument
-- accept 'ad' with an optional argument
--
-- If the first item in switches is '*', then Getopt will catch
-- every element on the command line that was not caught by any other
-- switch. The character returned by GetOpt is '*'
--
-- Example
-- Getopt ("* a b")
-- If the command line is '-a -c toto.o -b', GetOpt will return
-- successively 'a', '*', '*' and 'b'. When '*' is returnd,
-- Full_Switch returns the corresponding item on the command line.
--
--
-- When Getopt encounters an invalid switch, it raises the exception
-- Invalid_Switch and sets Full_Switch to return the invalid switch.
-- When Getopt can not find the parameter associated with a switch, it
-- raises Invalid_Parameter, and sets Full_Switch to return the invalid
-- switch character.
--
-- Note: in case of ambiguity, e.g. switches a ab abc, then the longest
-- matching switch is returned.
--
-- Arbitrary characters are allowed for switches, although it is
-- strongly recommanded to use only letters and digits for portability
-- reasons.
function Get_Argument (Do_Expansion : Boolean := False) return String;
-- Returns the next element in the command line which is not a switch.
-- This function should not be called before Getopt has returned
-- ASCII.NUL.
--
-- If Expansion is True, then the parameter on the command
-- line will considered as filename with wild cards, and will be
-- expanded. The matching file names will be returned one at a time.
-- When there are no more arguments on the command line, this function
-- returns an empty string. This is useful in non-Unix systems for
-- obtaining normal expansion of wild card references.
function Parameter return String;
-- Returns parameter associated with the last switch returned by Getopt.
-- If no parameter was associated with the last switch, or no previous
-- call has been made to Get_Argument, raises Invalid_Parameter.
-- If the last switch was associated with an optionnal argument and this
-- argument was not found on the command line, Parameter returns an empty
-- string
type Expansion_Iterator is limited private;
-- Type used during expansion of file names
procedure Start_Expansion
(Iterator : out Expansion_Iterator;
Pattern : String;
Directory : String := "";
Basic_Regexp : Boolean := True);
-- Initialize an wild card expansion. The next calls to Expansion will
-- return the next file name in Directory which match Pattern (Pattern
-- is a regular expression, using only the Unix shell and DOS syntax if
-- Basic_Regexp is True. When Directory is an empty string, the current
-- directory is searched.
function Expansion (Iterator : Expansion_Iterator) return String;
-- Return the next file in the directory matching the parameters given
-- to Start_Expansion and updates Iterator to point to the next entry.
-- Returns an empty string when there are no more files in the directory.
-- If Expansion is called again after an empty string has been returned,
-- then the exception GNAT.Directory_Operations.Directory_Error is raised.
Invalid_Section : exception;
-- Raised when an invalid section is selected by Goto_Section
Invalid_Switch : exception;
-- Raised when an invalid switch is detected in the command line
Invalid_Parameter : exception;
-- Raised when a parameter is missing, or an attempt is made to obtain
-- a parameter for a switch that does not allow a parameter
private
type Expansion_Iterator is limited record
Dir : GNAT.Directory_Operations.Dir_Type;
Regexp : GNAT.Regexp.Regexp;
end record;
end GNAT.Command_Line;

114
gcc/ada/g-curexc.ads Normal file
View File

@ -0,0 +1,114 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . C U R R E N T _ E X C E P T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1996-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides routines for obtaining the current exception
-- information in Ada 83 style. In Ada 83, there was no official method
-- for obtaining exception information, but a number of vendors supplied
-- routines for this purpose, and this package closely approximates the
-- interfaces supplied by DEC Ada 83 and VADS Ada.
-- The routines in this package are associated with a particular exception
-- handler, and can only be called from within an exception handler. See
-- also the package GNAT.Most_Recent_Exception, which provides access to
-- the most recently raised exception, and is not limited to static calls
-- from an exception handler.
package GNAT.Current_Exception is
pragma Pure (Current_Exception);
-----------------
-- Subprograms --
-----------------
function Exception_Information return String;
-- Returns the result of calling Ada.Exceptions.Exception_Information
-- with an argument that is the Exception_Occurrence corresponding to
-- the current exception. Returns the null string if called from outside
-- an exception handler.
function Exception_Message return String;
-- Returns the result of calling Ada.Exceptions.Exception_Message with
-- an argument that is the Exception_Occurrence corresponding to the
-- current exception. Returns the null string if called from outside an
-- exception handler.
function Exception_Name return String;
-- Returns the result of calling Ada.Exceptions.Exception_Name with
-- an argument that is the Exception_Occurrence corresponding to the
-- current exception. Returns the null string if called from outside
-- an exception handler.
-- Note: all these functions return useful information only if
-- called statically from within an exception handler, and they
-- return information about the exception corresponding to the
-- handler in which they appear. This is NOT the same as the most
-- recently raised exception. Consider the example:
-- exception
-- when Constraint_Error =>
-- begin
-- ...
-- exception
-- when Tasking_Error => ...
-- end;
--
-- -- Exception_xxx at this point returns the information about
-- -- the constraint error, not about any exception raised within
-- -- the nested block since it is the static nesting that counts.
-----------------------------------
-- Use of Library Level Renaming --
-----------------------------------
-- For greater compatibility with existing legacy software, library
-- level renaming may be used to create a function with a name matching
-- one that is in use. For example, some versions of VADS Ada provided
-- a functin called Current_Exception whose semantics was identical to
-- that of GNAT. The following library level renaming declaration:
-- with GNAT.Current_Exception;
-- function Current_Exception
-- renames GNAT.Current_Exception.Exception_Name;
-- placed in a file called current_exception.ads and compiled into the
-- application compilation environment, will make the function available
-- in a manner exactly compatible with that in VADS Ada 83.
private
pragma Import (Intrinsic, Exception_Information);
pragma Import (intrinsic, Exception_Message);
pragma Import (Intrinsic, Exception_Name);
end GNAT.Current_Exception;

223
gcc/ada/g-debpoo.adb Normal file
View File

@ -0,0 +1,223 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D E B U G _ P O O L S --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Unchecked_Conversion;
with GNAT.HTable;
with System.Memory;
pragma Elaborate_All (GNAT.HTable);
package body GNAT.Debug_Pools is
use System;
use System.Memory;
use System.Storage_Elements;
-- Definition of a H-table storing the status of each storage chunck
-- used by this pool
type State is (Not_Allocated, Deallocated, Allocated);
type Header is range 1 .. 1023;
function H (F : Address) return Header;
package Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header,
Element => State,
No_Element => Not_Allocated,
Key => Address,
Hash => H,
Equal => "=");
--------------
-- Allocate --
--------------
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count) is
begin
Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
if Storage_Address = Null_Address then
raise Storage_Error;
else
Table.Set (Storage_Address, Allocated);
Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
if Pool.Allocated - Pool.Deallocated > Pool.High_Water then
Pool.High_Water := Pool.Allocated - Pool.Deallocated;
end if;
end if;
end Allocate;
----------------
-- Deallocate --
----------------
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
procedure Free (Address : System.Address; Siz : Storage_Count);
-- Faked free, that reset all the deallocated storage to "DEADBEEF"
procedure Free (Address : System.Address; Siz : Storage_Count) is
DB1 : constant Integer := 16#DEAD#;
DB2 : constant Integer := 16#BEEF#;
type Dead_Memory is array (1 .. Siz / 4) of Integer;
type Mem_Ptr is access all Dead_Memory;
function From_Ptr is
new Unchecked_Conversion (System.Address, Mem_Ptr);
J : Storage_Offset;
begin
J := Dead_Memory'First;
while J < Dead_Memory'Last loop
From_Ptr (Address) (J) := DB1;
From_Ptr (Address) (J + 1) := DB2;
J := J + 2;
end loop;
if J = Dead_Memory'Last then
From_Ptr (Address) (J) := DB1;
end if;
end Free;
S : State := Table.Get (Storage_Address);
-- Start of processing for Deallocate
begin
case S is
when Not_Allocated =>
raise Freeing_Not_Allocated_Storage;
when Deallocated =>
raise Freeing_Deallocated_Storage;
when Allocated =>
Free (Storage_Address, Size_In_Storage_Elements);
Table.Set (Storage_Address, Deallocated);
Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
end case;
end Deallocate;
-----------------
-- Dereference --
-----------------
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
S : State := Table.Get (Storage_Address);
Max_Dim : constant := 3;
Dim : Integer := 1;
begin
-- If this is not a known address, maybe it is because is is an
-- unconstained array. In which case, the bounds have used the
-- 2 first words (per dimension) of the allocated spot.
while S = Not_Allocated and then Dim <= Max_Dim loop
S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
Dim := Dim + 1;
end loop;
case S is
when Not_Allocated =>
raise Accessing_Not_Allocated_Storage;
when Deallocated =>
raise Accessing_Deallocated_Storage;
when Allocated =>
null;
end case;
end Dereference;
-------
-- H --
-------
function H (F : Address) return Header is
begin
return
Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
end H;
----------------
-- Print_Info --
----------------
procedure Print_Info (Pool : Debug_Pool) is
use System.Storage_Elements;
begin
Put_Line ("Debug Pool info:");
Put_Line (" Total allocated bytes : "
& Storage_Offset'Image (Pool.Allocated));
Put_Line (" Total deallocated bytes : "
& Storage_Offset'Image (Pool.Deallocated));
Put_Line (" Current Water Mark: "
& Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
Put_Line (" High Water Mark: "
& Storage_Offset'Image (Pool.High_Water));
Put_Line ("");
end Print_Info;
------------------
-- Storage_Size --
------------------
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
begin
return Storage_Count'Last;
end Storage_Size;
end GNAT.Debug_Pools;

105
gcc/ada/g-debpoo.ads Normal file
View File

@ -0,0 +1,105 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D E B U G _ P O O L S --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Checked_Pools;
package GNAT.Debug_Pools is
-- The debug pool is used to track down memory corruption due to use of
-- deallocated memory or incorrect unchecked conversions. Allocation
-- strategy :
-- - allocation: . memory is normally allocated with malloc
-- . the allocated address is noted in a table
-- - deallocation: . memory is filled with "DEAD_BEEF" patterns
-- . memory is not freed
-- . exceptions are raised if the memory was not
-- allocated or was already deallocated
-- - dereference: . exceptions are raised if the memory was not
-- allocated or was already deallocated
Accessing_Not_Allocated_Storage : exception;
Accessing_Deallocated_Storage : exception;
Freeing_Not_Allocated_Storage : exception;
Freeing_Deallocated_Storage : exception;
type Debug_Pool is
new System.Checked_Pools.Checked_Pool with private;
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
function Storage_Size
(Pool : Debug_Pool)
return System.Storage_Elements.Storage_Count;
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : System.Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
generic
with procedure Put_Line (S : String);
procedure Print_Info (Pool : Debug_Pool);
-- Print out information about the High Water Mark, the current and
-- total number of bytes allocated and the total number of bytes
-- deallocated.
private
type Debug_Pool is new System.Checked_Pools.Checked_Pool with record
Allocated : Storage_Count := 0;
-- Total number of bytes allocated in this pool
Deallocated : Storage_Count := 0;
-- Total number of bytes deallocated in this pool
High_Water : Storage_Count := 0;
-- Maximum of during the time of Allocated - Deallocated
end record;
end GNAT.Debug_Pools;

111
gcc/ada/g-debuti.adb Normal file
View File

@ -0,0 +1,111 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . D E B U G _ U T I L I T I E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1997-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
package body GNAT.Debug_Utilities is
--------------------------
-- Image (address case) --
--------------------------
function Image (A : Address) return String is
S : String (1 .. Address_Image_Length);
P : Natural := S'Last - 1;
N : Integer_Address := To_Integer (A);
U : Natural := 0;
H : array (Integer range 0 .. 15) of Character := "0123456789ABCDEF";
begin
S (S'Last) := '#';
while P > 3 loop
if U = 4 then
S (P) := '_';
P := P - 1;
U := 1;
else
U := U + 1;
end if;
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
end loop;
S (1 .. 3) := "16#";
return S;
end Image;
-------------------------
-- Image (string case) --
-------------------------
function Image (S : String) return String is
W : String (1 .. 2 * S'Length + 2);
P : Positive := 1;
begin
W (1) := '"';
for J in S'Range loop
if S (J) = '"' then
P := P + 1;
W (P) := '"';
end if;
P := P + 1;
W (P) := S (J);
end loop;
P := P + 1;
W (P) := '"';
return W (1 .. P);
end Image;
-----------
-- Value --
-----------
function Value (S : String) return System.Address is
N : constant Integer_Address := Integer_Address'Value (S);
begin
return To_Address (N);
end Value;
end GNAT.Debug_Utilities;

63
gcc/ada/g-debuti.ads Normal file
View File

@ -0,0 +1,63 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . D E B U G _ U T I L I T I E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Debugging utilities
-- This package provides some useful utility subprograms for use in writing
-- routines that generate debugging output.
with System;
package GNAT.Debug_Utilities is
pragma Pure (Debug_Utilities);
function Image (S : String) return String;
-- Returns a string image of S, obtained by prepending and appending
-- quote (") characters and doubling any quote characters in the string.
-- The maximum length of the result is thus 2 ** S'Length + 2.
Address_Image_Length : constant :=
13 + 10 * Boolean'Pos (Standard'Address_Size > 32);
-- Length of string returned by Image function
function Image (A : System.Address) return String;
-- Returns a string of the form 16#xxxx_xxxx# for 32-bit addresses
-- or 16#xxxx_xxxx_xxxx_xxxx# for 64-bit addresses. Hex characters
-- are in upper case.
function Value (S : String) return System.Address;
-- Given a valid integer literal in any form, including the form returned
-- by the Image function in this package, yields the corresponding address.
end GNAT.Debug_Utilities;

981
gcc/ada/g-dirope.adb Normal file
View File

@ -0,0 +1,981 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.15 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded;
with Ada.Strings.Maps;
with Unchecked_Deallocation;
with Unchecked_Conversion;
with System; use System;
with GNAT.Regexp;
with GNAT.OS_Lib;
package body GNAT.Directory_Operations is
use Ada;
type Dir_Type_Value is new System.Address;
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
Dir_Seps : constant Strings.Maps.Character_Set :=
Strings.Maps.To_Set ("/\");
-- UNIX and DOS style directory separators.
procedure Free is new
Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
---------------
-- Base_Name --
---------------
function Base_Name
(Path : Path_Name;
Suffix : String := "")
return String
is
function Get_File_Names_Case_Sensitive return Integer;
pragma Import
(C, Get_File_Names_Case_Sensitive,
"__gnat_get_file_names_case_sensitive");
Case_Sensitive_File_Name : constant Boolean :=
Get_File_Names_Case_Sensitive = 1;
function Basename
(Path : Path_Name;
Suffix : String := "")
return String;
-- This function does the job. The only difference between Basename
-- and Base_Name (the parent function) is that the former is case
-- sensitive, while the latter is not. Path and Suffix are adjusted
-- appropriately before calling Basename under platforms where the
-- file system is not case sensitive.
--------------
-- Basename --
--------------
function Basename
(Path : Path_Name;
Suffix : String := "")
return String
is
Cut_Start : Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
Cut_End : Natural;
begin
-- Cut_Start point to the first basename character
if Cut_Start = 0 then
Cut_Start := Path'First;
else
Cut_Start := Cut_Start + 1;
end if;
-- Cut_End point to the last basename character.
Cut_End := Path'Last;
-- If basename ends with Suffix, adjust Cut_End.
if Suffix /= ""
and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
then
Cut_End := Path'Last - Suffix'Length;
end if;
Check_For_Standard_Dirs : declare
BN : constant String := Base_Name.Path (Cut_Start .. Cut_End);
begin
if BN = "." or else BN = ".." then
return "";
elsif BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then
-- We have a DOS drive letter prefix, remove it
return BN (BN'First + 2 .. BN'Last);
else
return BN;
end if;
end Check_For_Standard_Dirs;
end Basename;
-- Start processing for Base_Name
begin
if Case_Sensitive_File_Name then
return Basename (Path, Suffix);
else
return Basename
(Characters.Handling.To_Lower (Path),
Characters.Handling.To_Lower (Suffix));
end if;
end Base_Name;
----------------
-- Change_Dir --
----------------
procedure Change_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
function chdir (Dir_Name : String) return Integer;
pragma Import (C, chdir, "chdir");
begin
if chdir (C_Dir_Name) /= 0 then
raise Directory_Error;
end if;
end Change_Dir;
-----------
-- Close --
-----------
procedure Close (Dir : in out Dir_Type) is
function closedir (Directory : System.Address) return Integer;
pragma Import (C, closedir, "closedir");
Discard : Integer;
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Discard := closedir (System.Address (Dir.all));
Free (Dir);
end Close;
--------------
-- Dir_Name --
--------------
function Dir_Name (Path : Path_Name) return Dir_Name_Str is
Last_DS : constant Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
begin
if Last_DS = 0 then
-- There is no directory separator, returns current working directory
return "." & Dir_Separator;
else
return Path (Path'First .. Last_DS);
end if;
end Dir_Name;
-----------------
-- Expand_Path --
-----------------
function Expand_Path (Path : Path_Name) return String is
use Ada.Strings.Unbounded;
procedure Read (K : in out Positive);
-- Update Result while reading current Path starting at position K. If
-- a variable is found, call Var below.
procedure Var (K : in out Positive);
-- Translate variable name starting at position K with the associated
-- environement value.
procedure Free is
new Unchecked_Deallocation (String, OS_Lib.String_Access);
Result : Unbounded_String;
----------
-- Read --
----------
procedure Read (K : in out Positive) is
begin
For_All_Characters : loop
if Path (K) = '$' then
-- Could be a variable
if K < Path'Last then
if Path (K + 1) = '$' then
-- Not a variable after all, this is a double $, just
-- insert one in the result string.
Append (Result, '$');
K := K + 1;
else
-- Let's parse the variable
K := K + 1;
Var (K);
end if;
else
-- We have an ending $ sign
Append (Result, '$');
end if;
else
-- This is a standard character, just add it to the result
Append (Result, Path (K));
end if;
-- Skip to next character
K := K + 1;
exit For_All_Characters when K > Path'Last;
end loop For_All_Characters;
end Read;
---------
-- Var --
---------
procedure Var (K : in out Positive) is
E : Positive;
begin
if Path (K) = '{' then
-- Look for closing } (curly bracket).
E := K;
loop
E := E + 1;
exit when Path (E) = '}' or else E = Path'Last;
end loop;
if Path (E) = '}' then
-- OK found, translate with environement value
declare
Env : OS_Lib.String_Access :=
OS_Lib.Getenv (Path (K + 1 .. E - 1));
begin
Append (Result, Env.all);
Free (Env);
end;
else
-- No closing curly bracket, not a variable after all or a
-- syntax error, ignore it, insert string as-is.
Append (Result, '$' & Path (K .. E));
end if;
else
-- The variable name is everything from current position to first
-- non letter/digit character.
E := K;
-- Check that first chartacter is a letter
if Characters.Handling.Is_Letter (Path (E)) then
E := E + 1;
Var_Name : loop
exit Var_Name when E = Path'Last;
if Characters.Handling.Is_Letter (Path (E))
or else Characters.Handling.Is_Digit (Path (E))
then
E := E + 1;
else
E := E - 1;
exit Var_Name;
end if;
end loop Var_Name;
declare
Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
begin
Append (Result, Env.all);
Free (Env);
end;
else
-- This is not a variable after all
Append (Result, '$' & Path (E));
end if;
end if;
K := E;
end Var;
-- Start of processing for Expand_Path
begin
declare
K : Positive := Path'First;
begin
Read (K);
return To_String (Result);
end;
end Expand_Path;
--------------------
-- File_Extension --
--------------------
function File_Extension (Path : Path_Name) return String is
First : Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
Dot : Natural;
begin
if First = 0 then
First := Path'First;
end if;
Dot := Strings.Fixed.Index (Path (First .. Path'Last),
".",
Going => Strings.Backward);
if Dot = 0 or else Dot = Path'Last then
return "";
else
return Path (Dot .. Path'Last);
end if;
end File_Extension;
---------------
-- File_Name --
---------------
function File_Name (Path : Path_Name) return String is
begin
return Base_Name (Path);
end File_Name;
----------
-- Find --
----------
procedure Find
(Root_Directory : Dir_Name_Str;
File_Pattern : String)
is
File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern);
Index : Natural := 0;
procedure Read_Directory (Directory : Dir_Name_Str);
-- Open Directory and read all entries. This routine is called
-- recursively for each sub-directories.
function Make_Pathname (Dir, File : String) return String;
-- Returns the pathname for File by adding Dir as prefix.
-------------------
-- Make_Pathname --
-------------------
function Make_Pathname (Dir, File : String) return String is
begin
if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then
return Dir & File;
else
return Dir & Dir_Separator & File;
end if;
end Make_Pathname;
--------------------
-- Read_Directory --
--------------------
procedure Read_Directory (Directory : Dir_Name_Str) is
Dir : Dir_Type;
Buffer : String (1 .. 2_048);
Last : Natural;
Quit : Boolean;
begin
Open (Dir, Directory);
loop
Read (Dir, Buffer, Last);
exit when Last = 0;
declare
Dir_Entry : constant String := Buffer (1 .. Last);
Pathname : constant String
:= Make_Pathname (Directory, Dir_Entry);
begin
if Regexp.Match (Dir_Entry, File_Regexp) then
Quit := False;
Index := Index + 1;
begin
Action (Pathname, Index, Quit);
exception
when others =>
Close (Dir);
raise;
end;
exit when Quit;
end if;
-- Recursively call for sub-directories, except for . and ..
if not (Dir_Entry = "." or else Dir_Entry = "..")
and then OS_Lib.Is_Directory (Pathname)
then
Read_Directory (Pathname);
end if;
end;
end loop;
Close (Dir);
end Read_Directory;
begin
Read_Directory (Root_Directory);
end Find;
---------------------
-- Get_Current_Dir --
---------------------
Max_Path : Integer;
pragma Import (C, Max_Path, "max_path_len");
function Get_Current_Dir return Dir_Name_Str is
Current_Dir : String (1 .. Max_Path + 1);
Last : Natural;
begin
Get_Current_Dir (Current_Dir, Last);
return Current_Dir (1 .. Last);
end Get_Current_Dir;
procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
Path_Len : Natural := Max_Path;
Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
procedure Local_Get_Current_Dir
(Dir : System.Address;
Length : System.Address);
pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Dir'Length > Path_Len then
Last := Dir'First + Path_Len - 1;
else
Last := Dir'Last;
end if;
Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
end Get_Current_Dir;
-------------
-- Is_Open --
-------------
function Is_Open (Dir : Dir_Type) return Boolean is
begin
return Dir /= Null_Dir
and then System.Address (Dir.all) /= System.Null_Address;
end Is_Open;
--------------
-- Make_Dir --
--------------
procedure Make_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
function mkdir (Dir_Name : String) return Integer;
pragma Import (C, mkdir, "__gnat_mkdir");
begin
if mkdir (C_Dir_Name) /= 0 then
raise Directory_Error;
end if;
end Make_Dir;
------------------------
-- Normalize_Pathname --
------------------------
function Normalize_Pathname
(Path : Path_Name;
Style : Path_Style := System_Default)
return String
is
N_Path : String := Path;
K : Positive := N_Path'First;
Prev_Dirsep : Boolean := False;
begin
for J in Path'Range loop
if Strings.Maps.Is_In (Path (J), Dir_Seps) then
if not Prev_Dirsep then
case Style is
when UNIX => N_Path (K) := '/';
when DOS => N_Path (K) := '\';
when System_Default => N_Path (K) := Dir_Separator;
end case;
K := K + 1;
end if;
Prev_Dirsep := True;
else
N_Path (K) := Path (J);
K := K + 1;
Prev_Dirsep := False;
end if;
end loop;
return N_Path (N_Path'First .. K - 1);
end Normalize_Pathname;
----------
-- Open --
----------
procedure Open
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
C_File_Name : String := Dir_Name & ASCII.NUL;
function opendir
(File_Name : String)
return Dir_Type_Value;
pragma Import (C, opendir, "opendir");
begin
Dir := new Dir_Type_Value'(opendir (C_File_Name));
if not Is_Open (Dir) then
Free (Dir);
Dir := Null_Dir;
raise Directory_Error;
end if;
end Open;
----------
-- Read --
----------
procedure Read
(Dir : in out Dir_Type;
Str : out String;
Last : out Natural)
is
Filename_Addr : Address;
Filename_Len : Integer;
Buffer : array (0 .. 1024) of Character;
-- 1024 is the value of FILENAME_MAX in stdio.h
function readdir_gnat
(Directory : System.Address;
Buffer : System.Address)
return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
function strlen (S : Address) return Integer;
pragma Import (C, strlen, "strlen");
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Filename_Addr :=
readdir_gnat (System.Address (Dir.all), Buffer'Address);
if Filename_Addr = System.Null_Address then
Last := 0;
return;
end if;
Filename_Len := strlen (Filename_Addr);
if Str'Length > Filename_Len then
Last := Str'First + Filename_Len - 1;
else
Last := Str'Last;
end if;
declare
subtype Path_String is String (1 .. Filename_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new
Unchecked_Conversion
(Source => Address,
Target => Path_String_Access);
Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
begin
for J in Str'First .. Last loop
Str (J) := Path_Access (J - Str'First + 1);
end loop;
end;
end Read;
-------------------------
-- Read_Is_Thread_Sage --
-------------------------
function Read_Is_Thread_Safe return Boolean is
function readdir_is_thread_safe return Integer;
pragma Import
(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
begin
return (readdir_is_thread_safe /= 0);
end Read_Is_Thread_Safe;
----------------
-- Remove_Dir --
----------------
procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
procedure rmdir (Dir_Name : String);
pragma Import (C, rmdir, "rmdir");
begin
rmdir (C_Dir_Name);
end Remove_Dir;
-----------------------
-- Wildcard_Iterator --
-----------------------
procedure Wildcard_Iterator (Path : Path_Name) is
Index : Natural := 0;
procedure Read
(Directory : String;
File_Pattern : String;
Suffix_Pattern : String);
-- Read entries in Directory and call user's callback if the entry
-- match File_Pattern and Suffix_Pattern is empty otherwise it will go
-- down one more directory level by calling Next_Level routine above.
procedure Next_Level
(Current_Path : String;
Suffix_Path : String);
-- Extract next File_Pattern from Suffix_Path and call Read routine
-- above.
----------------
-- Next_Level --
----------------
procedure Next_Level
(Current_Path : String;
Suffix_Path : String)
is
DS : Natural;
SP : String renames Suffix_Path;
begin
if SP'Length > 2
and then SP (SP'First) = '.'
and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps)
then
-- Starting with "./"
DS := Strings.Fixed.Index
(SP (SP'First + 2 .. SP'Last),
Dir_Seps);
if DS = 0 then
-- We have "./"
Read (Current_Path & ".", "*", "");
else
-- We have "./dir"
Read (Current_Path & ".",
SP (SP'First + 2 .. DS - 1),
SP (DS .. SP'Last));
end if;
elsif SP'Length > 3
and then SP (SP'First .. SP'First + 1) = ".."
and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
then
-- Starting with "../"
DS := Strings.Fixed.Index
(SP (SP'First + 3 .. SP'Last),
Dir_Seps);
if DS = 0 then
-- We have "../"
Read (Current_Path & "..", "*", "");
else
-- We have "../dir"
Read (Current_Path & "..",
SP (SP'First + 4 .. DS - 1),
SP (DS .. SP'Last));
end if;
elsif Current_Path = ""
and then SP'Length > 1
and then Characters.Handling.Is_Letter (SP (SP'First))
and then SP (SP'First + 1) = ':'
then
-- Starting with "<drive>:"
if SP'Length > 2
and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
then
-- Starting with "<drive>:\"
DS := Strings.Fixed.Index
(SP (SP'First + 3 .. SP'Last), Dir_Seps);
if DS = 0 then
-- Se have "<drive>:\dir"
Read (SP (SP'First .. SP'First + 1),
SP (SP'First + 3 .. SP'Last),
"");
else
-- We have "<drive>:\dir\kkk"
Read (SP (SP'First .. SP'First + 1),
SP (SP'First + 3 .. DS - 1),
SP (DS .. SP'Last));
end if;
else
-- Starting with "<drive>:"
DS := Strings.Fixed.Index
(SP (SP'First + 2 .. SP'Last), Dir_Seps);
if DS = 0 then
-- We have "<drive>:dir"
Read (SP (SP'First .. SP'First + 1),
SP (SP'First + 2 .. SP'Last),
"");
else
-- We have "<drive>:dir/kkk"
Read (SP (SP'First .. SP'First + 1),
SP (SP'First + 2 .. DS - 1),
SP (DS .. SP'Last));
end if;
end if;
elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then
-- Starting with a /
DS := Strings.Fixed.Index
(SP (SP'First + 1 .. SP'Last),
Dir_Seps);
if DS = 0 then
-- We have "/dir"
Read (Current_Path,
SP (SP'First + 1 .. SP'Last),
"");
else
-- We have "/dir/kkk"
Read (Current_Path,
SP (SP'First + 1 .. DS - 1),
SP (DS .. SP'Last));
end if;
else
-- Starting with a name
DS := Strings.Fixed.Index (SP, Dir_Seps);
if DS = 0 then
-- We have "dir"
Read (Current_Path & '.',
SP,
"");
else
-- We have "dir/kkk"
Read (Current_Path & '.',
SP (SP'First .. DS - 1),
SP (DS .. SP'Last));
end if;
end if;
end Next_Level;
----------
-- Read --
----------
Quit : Boolean := False;
-- Global state to be able to exit all recursive calls.
procedure Read
(Directory : String;
File_Pattern : String;
Suffix_Pattern : String)
is
File_Regexp : constant Regexp.Regexp :=
Regexp.Compile (File_Pattern, Glob => True);
Dir : Dir_Type;
Buffer : String (1 .. 2_048);
Last : Natural;
begin
if OS_Lib.Is_Directory (Directory) then
Open (Dir, Directory);
Dir_Iterator : loop
Read (Dir, Buffer, Last);
exit Dir_Iterator when Last = 0;
declare
Dir_Entry : constant String := Buffer (1 .. Last);
Pathname : constant String :=
Directory & Dir_Separator & Dir_Entry;
begin
-- Handle "." and ".." only if explicit use in the
-- File_Pattern.
if not
((Dir_Entry = "." and then File_Pattern /= ".")
or else
(Dir_Entry = ".." and then File_Pattern /= ".."))
then
if Regexp.Match (Dir_Entry, File_Regexp) then
if Suffix_Pattern = "" then
-- No more matching needed, call user's callback
Index := Index + 1;
begin
Action (Pathname, Index, Quit);
exception
when others =>
Close (Dir);
raise;
end;
exit Dir_Iterator when Quit;
else
-- Down one level
Next_Level
(Directory & Dir_Separator & Dir_Entry,
Suffix_Pattern);
end if;
end if;
end if;
end;
exit Dir_Iterator when Quit;
end loop Dir_Iterator;
Close (Dir);
end if;
end Read;
begin
Next_Level ("", Path);
end Wildcard_Iterator;
end GNAT.Directory_Operations;

263
gcc/ada/g-dirope.ads Normal file
View File

@ -0,0 +1,263 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Directory operations
-- This package provides routines for manipulating directories. A directory
-- can be treated as a file, using open and close routines, and a scanning
-- routine is provided for iterating through the entries in a directory.
package GNAT.Directory_Operations is
subtype Dir_Name_Str is String;
-- A subtype used in this package to represent string values that are
-- directory names. A directory name is a prefix for files that appear
-- with in the directory. This means that for UNIX systems, the string
-- includes a final '/', and for DOS-like systems, it includes a final
-- '\' character. It can also include drive letters if the operating
-- system provides for this. The final '/' or '\' in a Dir_Name_Str is
-- optional when passed as a procedure or function in parameter.
type Dir_Type is limited private;
-- A value used to reference a directory. Conceptually this value includes
-- the identity of the directory, and a sequential position within it.
Null_Dir : constant Dir_Type;
-- Represent the value for an uninitialized or closed directory
Directory_Error : exception;
-- Exception raised if the directory cannot be opened, read, closed,
-- created or if it is not possible to change the current execution
-- environment directory.
Dir_Separator : constant Character;
-- Running system default directory separator
--------------------------------
-- Basic Directory operations --
--------------------------------
procedure Change_Dir (Dir_Name : Dir_Name_Str);
-- Changes the working directory of the current execution environment
-- to the directory named by Dir_Name. Raises Directory_Error if Dir_Name
-- does not exist.
procedure Make_Dir (Dir_Name : Dir_Name_Str);
-- Create a new directory named Dir_Name. Raises Directory_Error if
-- Dir_Name cannot be created.
procedure Remove_Dir (Dir_Name : Dir_Name_Str);
-- Remove the directory named Dir_Name. Raises Directory_Error if Dir_Name
-- cannot be removed.
function Get_Current_Dir return Dir_Name_Str;
-- Returns the current working directory for the execution environment.
procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural);
-- Returns the current working directory for the execution environment
-- The name is returned in Dir_Name. Last is the index in Dir_Name such
-- that Dir_Name (Last) is the last character written. If Dir_Name is
-- too small for the directory name, the name will be truncated before
-- being copied to Dir_Name.
-------------------------
-- Pathname Operations --
-------------------------
subtype Path_Name is String;
-- All routines using Path_Name handle both styles (UNIX and DOS) of
-- directory separators (either slash or back slash).
function Dir_Name (Path : Path_Name) return Dir_Name_Str;
-- Returns directory name for Path. This is similar to the UNIX dirname
-- command. Everything after the last directory separator is removed. If
-- there is no directory separator the current working directory is
-- returned.
function Base_Name
(Path : Path_Name;
Suffix : String := "")
return String;
-- Any directory prefix is removed. If Suffix is non-empty and is a
-- suffix of Path, it is removed. This is equivalent to the UNIX basename
-- command. The following rule is always true:
--
-- 'Path' and 'Dir_Name (Path) & Directory_Separator & Base_Name (Path)'
-- represent the same file.
--
-- This function is not case-sensitive on systems that have a non
-- case-sensitive file system like Windows, OS/2 and VMS.
function File_Extension (Path : Path_Name) return String;
-- Return the file extension. This is the string after the last dot
-- character in File_Name (Path). It returns the empty string if no
-- extension is found. The returned value does contains the file
-- extension separator (dot character).
function File_Name (Path : Path_Name) return String;
-- Returns the file name and the file extension if present. It removes all
-- path information. This is equivalent to Base_Name with default Extension
-- value.
type Path_Style is (UNIX, DOS, System_Default);
function Normalize_Pathname
(Path : Path_Name;
Style : Path_Style := System_Default)
return Path_Name;
-- Removes all double directory separator and converts all '\' to '/' if
-- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This
-- function will help to provide a consistent naming scheme running for
-- different environments. If style is set to System_Default the routine
-- will use the default directory separator on the running environment.
function Expand_Path (Path : Path_Name) return Path_Name;
-- Returns Path with environment variables (string preceded by a dollar
-- sign) replaced by the current environment variable value. For example,
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
-- variable is set to /home/joe. The variable can be surrounded by the
-- characters '{' and '}' (curly bracket) if needed as in ${HOME}/mydir.
-- If an environment variable does not exists the variable will be replaced
-- by the empty string. Two dollar signs are replaced by a single dollar
-- sign. Note that a variable must start with a letter. If there is no
-- closing curly bracket for an opening one there is no translation done,
-- so for example ${VAR/toto is returned as ${VAR/toto.
---------------
-- Iterators --
---------------
procedure Open (Dir : out Dir_Type; Dir_Name : Dir_Name_Str);
-- Opens the directory named by Dir_Name and returns a Dir_Type value
-- that refers to this directory, and is positioned at the first entry.
-- Raises Directory_Error if Dir_Name cannot be accessed. In that case
-- Dir will be set to Null_Dir.
procedure Close (Dir : in out Dir_Type);
-- Closes the directory stream refered to by Dir. After calling Close
-- Is_Open will return False. Dir will be set to Null_Dir.
-- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir).
function Is_Open (Dir : Dir_Type) return Boolean;
-- Returns True if Dir is open, or False otherwise.
procedure Read
(Dir : in out Dir_Type;
Str : out String;
Last : out Natural);
-- Reads the next entry from the directory and sets Str to the name
-- of that entry. Last is the index in Str such that Str (Last) is the
-- last character written. Last is 0 when there are no more files in the
-- directory. If Str is too small for the file name, the file name will
-- be truncated before being copied to Str. The list of files returned
-- includes directories in systems providing a hierarchical directory
-- structure, including . (the current directory) and .. (the parent
-- directory) in systems providing these entries. The directory is
-- returned in target-OS form. Raises Directory_Error if Dir has not
-- be opened (Dir = Null_Dir).
generic
with procedure Action
(Item : String;
Index : Positive;
Quit : in out Boolean);
procedure Wildcard_Iterator (Path : Path_Name);
-- Calls Action for each path matching Path. Path can include wildcards '*'
-- and '?' and [...]. The rules are:
--
-- * can be replaced by any sequence of characters
-- ? can be replaced by a single character
-- [a-z] match one character in the range 'a' through 'z'
-- [abc] match either character 'a', 'b' or 'c'
--
-- Item is the filename that has been matched. Index is set to one for the
-- first call and is incremented by one at each call. The iterator's
-- termination can be controlled by setting Quit to True. It is by default
-- set to False.
--
-- For example, if we have the following directory structure:
-- /boo/
-- foo.ads
-- /sed/
-- foo.ads
-- file/
-- foo.ads
-- /sid/
-- foo.ads
-- file/
-- foo.ads
-- /life/
--
-- A call with expression "/s*/file/*" will call Action for the following
-- items:
-- /sed/file/foo.ads
-- /sid/file/foo.ads
generic
with procedure Action
(Item : String;
Index : Positive;
Quit : in out Boolean);
procedure Find
(Root_Directory : Dir_Name_Str;
File_Pattern : String);
-- Recursively searches the directory structure rooted at Root_Directory.
-- This provides functionality similar to the UNIX 'find' command.
-- Action will be called for every item matching the regular expression
-- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file
-- starting with Root_Directory that has been matched. Index is set to one
-- for the first call and is incremented by one at each call. The iterator
-- will pass in the value False on each call to Action. The iterator will
-- terminate after passing the last matched path to Action or after
-- returning from a call to Action which sets Quit to True.
-- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed.
function Read_Is_Thread_Safe return Boolean;
-- Indicates if procedure Read is thread safe. On systems where the
-- target system supports this functionality, Read is thread safe,
-- and this function returns True (e.g. this will be the case on any
-- UNIX or UNIX-like system providing a correct implementation of the
-- function readdir_r). If the system cannot provide a thread safe
-- implementation of Read, then this function returns False.
private
type Dir_Type_Value;
type Dir_Type is access Dir_Type_Value;
Null_Dir : constant Dir_Type := null;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
end GNAT.Directory_Operations;

246
gcc/ada/g-dyntab.adb Normal file
View File

@ -0,0 +1,246 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D Y N A M I C _ T A B L E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
package body GNAT.Dynamic_Tables is
Min : constant Integer := Integer (Table_Low_Bound);
-- Subscript of the minimum entry in the currently allocated table
type size_t is new Integer;
-----------------------
-- Local Subprograms --
-----------------------
procedure Reallocate (T : in out Instance);
-- Reallocate the existing table according to the current value stored
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
--------------
-- Allocate --
--------------
procedure Allocate
(T : in out Instance;
Num : Integer := 1)
is
begin
T.P.Last_Val := T.P.Last_Val + Num;
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end Allocate;
------------
-- Append --
------------
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
begin
Increment_Last (T);
T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val;
end Append;
--------------------
-- Decrement_Last --
--------------------
procedure Decrement_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val - 1;
end Decrement_Last;
----------
-- Free --
----------
procedure Free (T : in out Instance) is
procedure free (T : Table_Ptr);
pragma Import (C, free);
begin
free (T.Table);
T.Table := null;
T.P.Length := 0;
end Free;
--------------------
-- Increment_Last --
--------------------
procedure Increment_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val + 1;
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end Increment_Last;
----------
-- Init --
----------
procedure Init (T : in out Instance) is
Old_Length : constant Integer := T.P.Length;
begin
T.P.Last_Val := Min - 1;
T.P.Max := Min + Table_Initial - 1;
T.P.Length := T.P.Max - Min + 1;
-- If table is same size as before (happens when table is never
-- expanded which is a common case), then simply reuse it. Note
-- that this also means that an explicit Init call right after
-- the implicit one in the package body is harmless.
if Old_Length = T.P.Length then
return;
-- Otherwise we can use Reallocate to get a table of the right size.
-- Note that Reallocate works fine to allocate a table of the right
-- initial size when it is first allocated.
else
Reallocate (T);
end if;
end Init;
----------
-- Last --
----------
function Last (T : in Instance) return Table_Index_Type is
begin
return Table_Index_Type (T.P.Last_Val);
end Last;
----------------
-- Reallocate --
----------------
procedure Reallocate (T : in out Instance) is
function realloc
(memblock : Table_Ptr;
size : size_t)
return Table_Ptr;
pragma Import (C, realloc);
function malloc
(size : size_t)
return Table_Ptr;
pragma Import (C, malloc);
New_Size : size_t;
begin
if T.P.Max < T.P.Last_Val then
while T.P.Max < T.P.Last_Val loop
T.P.Length := T.P.Length * (100 + Table_Increment) / 100;
T.P.Max := Min + T.P.Length - 1;
end loop;
end if;
New_Size :=
size_t ((T.P.Max - Min + 1) *
(Table_Type'Component_Size / Storage_Unit));
if T.Table = null then
T.Table := malloc (New_Size);
elsif New_Size > 0 then
T.Table :=
realloc
(memblock => T.Table,
size => New_Size);
end if;
if T.P.Length /= 0 and then T.Table = null then
raise Storage_Error;
end if;
end Reallocate;
-------------
-- Release --
-------------
procedure Release (T : in out Instance) is
begin
T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
T.P.Max := T.P.Last_Val;
Reallocate (T);
end Release;
--------------
-- Set_Item --
--------------
procedure Set_Item
(T : in out Instance;
Index : Table_Index_Type;
Item : Table_Component_Type)
is
begin
if Integer (Index) > T.P.Max then
Set_Last (T, Index);
end if;
T.Table (Index) := Item;
end Set_Item;
--------------
-- Set_Last --
--------------
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
begin
if Integer (New_Val) < T.P.Last_Val then
T.P.Last_Val := Integer (New_Val);
else
T.P.Last_Val := Integer (New_Val);
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end if;
end Set_Last;
end GNAT.Dynamic_Tables;

195
gcc/ada/g-dyntab.ads Normal file
View File

@ -0,0 +1,195 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D Y N A M I C _ T A B L E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Resizable one dimensional array support
-- This package provides an implementation of dynamically resizable one
-- dimensional arrays. The idea is to mimic the normal Ada semantics for
-- arrays as closely as possible with the one additional capability of
-- dynamically modifying the value of the Last attribute.
-- This package provides a facility similar to that of GNAT.Table, except
-- that this package declares a type that can be used to define dynamic
-- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type.
-- Note that this interface should remain synchronized with those in
-- GNAT.Table and the GNAT compiler source unit Table to keep as much
-- coherency as possible between these three related units.
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive;
Table_Increment : Natural;
package GNAT.Dynamic_Tables is
-- Table_Component_Type and Table_Index_Type specify the type of the
-- array, Table_Low_Bound is the lower bound. Index_type must be an
-- integer type. The effect is roughly to declare:
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
-- Table_Component_Type may be any Ada type, except that controlled
-- types are not supported. Note however that default initialization
-- will NOT occur for array components.
-- The Table_Initial values controls the allocation of the table when
-- it is first allocated, either by default, or by an explicit Init
-- call.
-- The Table_Increment value controls the amount of increase, if the
-- table has to be increased in size. The value given is a percentage
-- value (e.g. 100 = increase table size by 100%, i.e. double it).
-- The Last and Set_Last subprograms provide control over the current
-- logical allocation. They are quite efficient, so they can be used
-- freely (expensive reallocation occurs only at major granularity
-- chunks controlled by the allocation parameters).
-- Note: we do not make the table components aliased, since this would
-- restrict the use of table for discriminated types. If it is necessary
-- to take the access of a table element, use Unrestricted_Access.
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained
-- with the maximum possible range bound. This means that the pointer
-- is a thin pointer, which is more efficient. Since subscript checks
-- in any case must be on the logical, rather than physical bounds,
-- safety is not compromised by this approach.
type Table_Ptr is access all Big_Table_Type;
-- The table is actually represented as a pointer to allow
-- reallocation.
type Table_Private is private;
-- table private data that is not exported in Instance.
type Instance is record
Table : aliased Table_Ptr := null;
-- The table itself. The lower bound is the value of Low_Bound.
-- Logically the upper bound is the current value of Last (although
-- the actual size of the allocated table may be larger than this).
-- The program may only access and modify Table entries in the
-- range First .. Last.
P : Table_Private;
end record;
procedure Init (T : in out Instance);
-- This procedure allocates a new table of size Initial (freeing any
-- previously allocated larger table). Init must be called before using
-- the table. Init is convenient in reestablishing a table for new use.
function Last (T : in Instance) return Table_Index_Type;
pragma Inline (Last);
-- Returns the current value of the last used entry in the table,
-- which can then be used as a subscript for Table. Note that the
-- only way to modify Last is to call the Set_Last procedure. Last
-- must always be used to determine the logically last entry.
procedure Release (T : in out Instance);
-- Storage is allocated in chunks according to the values given in the
-- Initial and Increment parameters. A call to Release releases all
-- storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call.
procedure Free (T : in out Instance);
-- Free all allocated memory for the table. A call to init is required
-- before any use of this table after calling Free.
First : constant Table_Index_Type := Table_Low_Bound;
-- Export First as synonym for Low_Bound (parallel with use of Last)
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type);
pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the
-- table is reallocated to accomodate the new value (i.e. on return
-- the allocated table has an upper bound of at least Last). If
-- Set_Last reduces the size of the table, then logically entries are
-- removed from the table. If Set_Last increases the size of the
-- table, then new entries are logically added to the table.
procedure Increment_Last (T : in out Instance);
pragma Inline (Increment_Last);
-- Adds 1 to Last (same as Set_Last (Last + 1).
procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last);
-- Subtracts 1 from Last (same as Set_Last (Last - 1).
procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append);
-- Equivalent to:
-- Increment_Last (T);
-- T.Table (T.Last) := New_Val;
-- i.e. the table size is increased by one, and the given new item
-- stored in the newly created table element.
procedure Set_Item
(T : in out Instance;
Index : Table_Index_Type;
Item : Table_Component_Type);
pragma Inline (Set_Item);
-- Put Item in the table at position Index. The table is expanded if
-- current table length is less than Index and in that case Last is set to
-- Index. Item will replace any value already present in the table at this
-- position.
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
-- Adds Num to Last.
private
type Table_Private is record
Max : Integer;
-- Subscript of the maximum entry in the currently allocated table
Length : Integer := 0;
-- Number of entries in currently allocated table. The value of zero
-- ensures that we initially allocate the table.
Last_Val : Integer;
-- Current value of Last.
end record;
end GNAT.Dynamic_Tables;

79
gcc/ada/g-except.ads Normal file
View File

@ -0,0 +1,79 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides an interface for raising predefined exceptions
-- with an exception message. It can be used from Pure units. This unit
-- is for internal use only, it is not generally available to applications.
package GNAT.Exceptions is
pragma Pure (Exceptions);
type Exception_Type is limited null record;
-- Type used to specify which exception to raise.
-- Really Exception_Type is Exception_Id, but Exception_Id can't be
-- used directly since it is declared in the non-pure unit Ada.Exceptions,
-- Exception_Id is in fact simply a pointer to the type Exception_Data
-- declared in System.Standard_Library (which is also non-pure). So what
-- we do is to define it here as a by reference type (any by reference
-- type would do), and then Import the definitions from Standard_Library.
-- Since this is a by reference type, these will be passed by reference,
-- which has the same effect as passing a pointer.
-- This type is not private because keeping it by reference would require
-- defining it in a way (e.g a tagged type) that would drag other run time
-- files, which is unwanted in the case of e.g ravenscar where we want to
-- minimize the number of run time files needed by default.
CE : constant Exception_Type; -- Constraint_Error
PE : constant Exception_Type; -- Program_Error
SE : constant Exception_Type; -- Storage_Error
TE : constant Exception_Type; -- Tasking_Error
-- One of these constants is used in the call to specify the exception
procedure Raise_Exception (E : Exception_Type; Message : String);
pragma Import (Ada, Raise_Exception, "__gnat_raise_exception");
pragma No_Return (Raise_Exception);
-- Raise specified exception with specified message
private
pragma Import (C, CE, "constraint_error");
pragma Import (C, PE, "program_error");
pragma Import (C, SE, "storage_error");
pragma Import (C, TE, "tasking_error");
-- References to the exception structures in the standard library
end GNAT.Exceptions;

128
gcc/ada/g-exctra.adb Normal file
View File

@ -0,0 +1,128 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N _ T R A C E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links; use System.Soft_Links;
package body GNAT.Exception_Traces is
-- Calling the decorator directly from where it is needed would require
-- introducing nasty dependencies upon the spec of this package (typically
-- in a-except.adb). We also have to deal with the fact that the traceback
-- array within an exception occurrence and the one the decorator shall
-- accept are of different types. These are two reasons for which a wrapper
-- with a System.Address argument is indeed used to call the decorator
-- provided by the user of this package. This wrapper is called via a
-- soft-link, which either is null when no decorator is in place or "points
-- to" the following function otherwise.
function Decorator_Wrapper
(Traceback : System.Address;
Len : Natural)
return String;
-- The wrapper to be called when a decorator is in place for exception
-- backtraces.
--
-- Traceback is the address of the call chain array as stored in the
-- exception occurrence and Len is the number of significant addresses
-- contained in this array.
Current_Decorator : Traceback_Decorator := null;
-- The decorator to be called by the wrapper when it is not null, as set
-- by Set_Trace_Decorator. When this access is null, the wrapper is null
-- also and shall then not be called.
-----------------------
-- Decorator_Wrapper --
-----------------------
function Decorator_Wrapper
(Traceback : System.Address;
Len : Natural)
return String
is
Decorator_Traceback : Tracebacks_Array (1 .. Len);
for Decorator_Traceback'Address use Traceback;
-- Handle the "transition" from the array stored in the exception
-- occurrence to the array expected by the decorator.
pragma Import (Ada, Decorator_Traceback);
begin
return Current_Decorator.all (Decorator_Traceback);
end Decorator_Wrapper;
-------------------------
-- Set_Trace_Decorator --
-------------------------
procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
begin
Current_Decorator := Decorator;
if Current_Decorator /= null then
Traceback_Decorator_Wrapper := Decorator_Wrapper'Access;
else
Traceback_Decorator_Wrapper := null;
end if;
end Set_Trace_Decorator;
-- Trace_On/Trace_Off control the kind of automatic output to occur
-- by way of the global Exception_Trace variable.
---------------
-- Trace_Off --
---------------
procedure Trace_Off is
begin
Exception_Trace := RM_Convention;
end Trace_Off;
--------------
-- Trace_On --
--------------
procedure Trace_On (Kind : in Trace_Kind) is
begin
case Kind is
when Every_Raise =>
Exception_Trace := Every_Raise;
when Unhandled_Raise =>
Exception_Trace := Unhandled_Raise;
end case;
end Trace_On;
end GNAT.Exception_Traces;

94
gcc/ada/g-exctra.ads Normal file
View File

@ -0,0 +1,94 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . E X C E P T I O N _ T R A C E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides an interface allowing to control *automatic* output
-- to standard error upon exception occurrences (as opposed to explicit
-- generation of traceback information using GNAT.Traceback).
--
-- This output includes the basic information associated with the exception
-- (name, message) as well as a backtrace of the call chain at the point
-- where the exception occured. This backtrace is only output if the call
-- chain information is available, depending if the binder switch dedicated
-- to that purpose has been used or not.
--
-- The default backtrace is in the form of absolute code locations which may
-- be converted to corresponding source locations using the addr2line utility
-- or from within GDB. Please refer to GNAT.Traceback for information about
-- what is necessary to be able to exploit thisg possibility.
--
-- The backtrace output can also be customized by way of a "decorator" which
-- may return any string output in association with a provided call chain.
with GNAT.Traceback; use GNAT.Traceback;
package GNAT.Exception_Traces is
-- The following defines the exact situations in which raises will
-- cause automatic output of trace information.
type Trace_Kind is
(Every_Raise,
-- Denotes the initial raise event for any exception occurrence, either
-- explicit or due to a specific language rule, within the context of a
-- task or not.
Unhandled_Raise
-- Denotes the raise events corresponding to exceptions for which there
-- is no user defined handler, in particular, when a task dies due to an
-- unhandled exception.
);
-- The following procedures can be used to activate and deactivate
-- traces identified by the above trace kind values.
procedure Trace_On (Kind : in Trace_Kind);
-- Activate the traces denoted by Kind.
procedure Trace_Off;
-- Stop the tracing requested by the last call to Trace_On.
-- Has no effect if no such call has ever occurred.
-- The following provide the backtrace decorating facilities
type Traceback_Decorator is access
function (Traceback : Tracebacks_Array) return String;
-- A backtrace decorator is a function which returns the string to be
-- output for a call chain provided by way of a tracebacks array.
procedure Set_Trace_Decorator (Decorator : Traceback_Decorator);
-- Set the decorator to be used for future automatic outputs. Restore
-- the default behavior (output of raw addresses) if the provided
-- access value is null.
end GNAT.Exception_Traces;

1177
gcc/ada/g-expect.adb Normal file
View File

File diff suppressed because it is too large Load Diff

589
gcc/ada/g-expect.ads Normal file
View File

@ -0,0 +1,589 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . E X P E C T --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Currently this package is implemented on all native GNAT ports except
-- for VMS. It is not yet implemented for any of the cross-ports (e.g. it
-- is not available for VxWorks or LynxOS).
--
-- Usage
-- =====
--
-- This package provides a set of subprograms similar to what is available
-- with the standard Tcl Expect tool.
-- It allows you to easily spawn and communicate with an external process.
-- You can send commands or inputs to the process, and compare the output
-- with some expected regular expression.
--
-- Usage example:
--
-- Non_Blocking_Spawn (Fd, "ftp machine@domaine");
-- Timeout := 10000; -- 10 seconds
-- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"),
-- Timeout);
-- case Result is
-- when 1 => Send (Fd, "my_name"); -- matched "user"
-- when 2 => Send (Fd, "my_passwd"); -- matched "passwd"
-- when Expect_Timeout => null; -- timeout
-- when others => null;
-- end case;
-- Close (Fd);
--
-- You can also combine multiple regular expressions together, and get the
-- specific string matching a parenthesis pair by doing something like. If you
-- expect either "lang=optional ada" or "lang=ada" from the external process,
-- you can group the two together, which is more efficient, and simply get the
-- name of the language by doing:
--
-- declare
-- Matched : Regexp_Array (0 .. 2);
-- begin
-- Expect (Fd, Result, "lang=(optional)? ([a-z]+)", Matched);
-- Put_Line ("Seen: " &
-- Expect_Out (Fd) (Matched (2).First .. Matched (2).Last));
-- end;
--
-- Alternatively, you might choose to use a lower-level interface to the
-- processes, where you can give your own input and output filters every
-- time characters are read from or written to the process.
--
-- procedure My_Filter (Descriptor : Process_Descriptor; Str : String) is
-- begin
-- Put_Line (Str);
-- end;
--
-- Fd := Non_Blocking_Spawn ("tail -f a_file");
-- Add_Filter (Fd, My_Filter'Access, Output);
-- Expect (Fd, Result, "", 0); -- wait forever
--
-- The above example should probably be run in a separate task, since it is
-- blocking on the call to Expect.
--
-- Both examples can be combined, for instance to systematically print the
-- output seen by expect, even though you still want to let Expect do the
-- filtering. You can use the Trace_Filter subprogram for such a filter.
--
-- If you want to get the output of a simple command, and ignore any previous
-- existing output, it is recommended to do something like:
--
-- Expect (Fd, Result, ".*", Timeout => 0);
-- -- empty the buffer, by matching everything (after checking
-- -- if there was any input).
-- Send (Fd, "command");
-- Expect (Fd, Result, ".."); -- match only on the output of command
--
-- Task Safety
-- ===========
--
-- This package is not task-safe. However, you can easily make is task safe
-- by encapsulating the type Process_Descriptor in a protected record.
-- There should not be concurrent calls to Expect.
with System;
with GNAT.OS_Lib;
with GNAT.Regpat;
package GNAT.Expect is
type Process_Id is new Integer;
Invalid_Pid : constant Process_Id := -1;
Null_Pid : constant Process_Id := 0;
type Filter_Type is (Output, Input, Died);
-- The signals that are emitted by the Process_Descriptor upon state
-- changed in the child. One can connect to any of this signal through
-- the Add_Filter subprograms.
--
-- Output => Every time new characters are read from the process
-- associated with Descriptor, the filter is called with
-- these new characters in argument.
--
-- Note that output is only generated when the program is
-- blocked in a call to Expect.
--
-- Input => Every time new characters are written to the process
-- associated with Descriptor, the filter is called with
-- these new characters in argument.
-- Note that input is only generated by calls to Send.
--
-- Died => The child process has died, or was explicitly killed
type Process_Descriptor is tagged private;
-- Contains all the components needed to describe a process handled
-- in this package, including a process identifier, file descriptors
-- associated with the standard input, output and error, and the buffer
-- needed to handle the expect calls.
type Process_Descriptor_Access is access Process_Descriptor'Class;
------------------------
-- Spawning a process --
------------------------
procedure Non_Blocking_Spawn
(Descriptor : out Process_Descriptor'Class;
Command : String;
Args : GNAT.OS_Lib.Argument_List;
Buffer_Size : Natural := 4096;
Err_To_Out : Boolean := False);
-- This call spawns a new process and allows sending commands to
-- the process and/or automatic parsing of the output.
--
-- The expect buffer associated with that process can contain at most
-- Buffer_Size characters. Older characters are simply discarded when
-- this buffer is full. Beware that if the buffer is too big, this could
-- slow down the Expect calls if not output is matched, since Expect has
-- to match all the regexp against all the characters in the buffer.
-- If Buffer_Size is 0, there is no limit (ie all the characters are kept
-- till Expect matches), but this is slower.
--
-- If Err_To_Out is True, then the standard error of the spawned process is
-- connected to the standard output. This is the only way to get the
-- Except subprograms also match on output on standard error.
--
-- Invalid_Process is raised if the process could not be spawned.
procedure Close (Descriptor : in out Process_Descriptor);
-- Terminate the process and close the pipes to it. It implicitly
-- does the 'wait' command required to clean up the process table.
-- This also frees the buffer associated with the process id.
procedure Send_Signal
(Descriptor : Process_Descriptor;
Signal : Integer);
-- Send a given signal to the process.
procedure Interrupt (Descriptor : in out Process_Descriptor);
-- Interrupt the process (the equivalent of Ctrl-C on unix and windows)
-- and call close if the process dies.
function Get_Input_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor;
-- Return the input file descriptor associated with Descriptor.
function Get_Output_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor;
-- Return the output file descriptor associated with Descriptor.
function Get_Error_Fd
(Descriptor : Process_Descriptor)
return GNAT.OS_Lib.File_Descriptor;
-- Return the error output file descriptor associated with Descriptor.
function Get_Pid
(Descriptor : Process_Descriptor)
return Process_Id;
-- Return the process id assocated with a given process descriptor.
--------------------
-- Adding filters --
--------------------
-- This is a rather low-level interface to subprocesses, since basically
-- the filtering is left entirely to the user. See the Expect subprograms
-- below for higher level functions.
type Filter_Function is access
procedure
(Descriptor : Process_Descriptor'Class;
Str : String;
User_Data : System.Address := System.Null_Address);
-- Function called every time new characters are read from or written
-- to the process.
--
-- Str is a string of all these characters.
--
-- User_Data, if specified, is a user specific data that will be passed to
-- the filter. Note that no checks are done on this parameter that should
-- be used with cautiousness.
procedure Add_Filter
(Descriptor : in out Process_Descriptor;
Filter : Filter_Function;
Filter_On : Filter_Type := Output;
User_Data : System.Address := System.Null_Address;
After : Boolean := False);
-- Add a new filter for one of the filter type. This filter will be
-- run before all the existing filters, unless After is set True,
-- in which case it will be run after existing filters. User_Data
-- is passed as is to the filter procedure.
procedure Remove_Filter
(Descriptor : in out Process_Descriptor;
Filter : Filter_Function);
-- Remove a filter from the list of filters (whatever the type of the
-- filter).
procedure Trace_Filter
(Descriptor : Process_Descriptor'Class;
Str : String;
User_Data : System.Address := System.Null_Address);
-- Function that can be used a filter and that simply outputs Str on
-- Standard_Output. This is mainly used for debugging purposes.
-- User_Data is ignored.
procedure Lock_Filters (Descriptor : in out Process_Descriptor);
-- Temporarily disables all output and input filters. They will be
-- reactivated only when Unlock_Filters has been called as many times as
-- Lock_Filters;
procedure Unlock_Filters (Descriptor : in out Process_Descriptor);
-- Unlocks the filters. They are reactivated only if Unlock_Filters
-- has been called as many times as Lock_Filters.
------------------
-- Sending data --
------------------
procedure Send
(Descriptor : in out Process_Descriptor;
Str : String;
Add_LF : Boolean := True;
Empty_Buffer : Boolean := False);
-- Send a string to the file descriptor.
--
-- The string is not formatted in any way, except if Add_LF is True,
-- in which case an ASCII.LF is added at the end, so that Str is
-- recognized as a command by the external process.
--
-- If Empty_Buffer is True, any input waiting from the process (or in the
-- buffer) is first discarded before the command is sent. The output
-- filters are of course called as usual.
-----------------------------------------------------------
-- Working on the output (single process, simple regexp) --
-----------------------------------------------------------
type Expect_Match is new Integer;
Expect_Full_Buffer : constant Expect_Match := -1;
-- If the buffer was full and some characters were discarded.
Expect_Timeout : constant Expect_Match := -2;
-- If not output matching the regexps was found before the timeout.
function "+" (S : String) return GNAT.OS_Lib.String_Access;
-- Allocate some memory for the string. This is merely a convenience
-- convenience function to help create the array of regexps in the
-- call to Expect.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexp : String;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Wait till a string matching Fd can be read from Fd, and return 1
-- if a match was found.
--
-- It consumes all the characters read from Fd until a match found, and
-- then sets the return values for the subprograms Expect_Out and
-- Expect_Out_Match.
--
-- The empty string "" will never match, and can be used if you only want
-- to match after a specific timeout. Beware that if Timeout is -1 at the
-- time, the current task will be blocked forever.
--
-- This command times out after Timeout milliseconds (or never if Timeout
-- is -1). In that case, Expect_Timeout is returned. The value returned by
-- Expect_Out and Expect_Out_Match are meaningless in that case.
--
-- Note that using a timeout of 0ms leads to unpredictable behavior, since
-- the result depends on whether the process has already sent some output
-- the first time Expect checks, and this depends on the operating system.
--
-- The regular expression must obey the syntax described in GNAT.Regpat.
--
-- If Full_Buffer is True, then Expect will match if the buffer was too
-- small and some characters were about to be discarded. In that case,
-- Expect_Full_Buffer is returned.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexp : GNAT.Regpat.Pattern_Matcher;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as the previous one, but with a precompiled regular expression.
-- This is more efficient however, especially if you are using this
-- expression multiple times, since this package won't need to recompile
-- the regexp every time.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexp : String;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as above, but it is now possible to get the indexes of the
-- substrings for the parentheses in the regexp (see the example at the
-- top of this package, as well as the documentation in the package
-- GNAT.Regpat).
--
-- Matched'First should be 0, and this index will contain the indexes for
-- the whole string that was matched. The index 1 will contain the indexes
-- for the first parentheses-pair, and so on.
------------
-- Expect --
------------
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexp : GNAT.Regpat.Pattern_Matcher;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as above, but with a precompiled regular expression.
-------------------------------------------------------------
-- Working on the output (single process, multiple regexp) --
-------------------------------------------------------------
type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access;
type Pattern_Matcher_Access is access GNAT.Regpat.Pattern_Matcher;
type Compiled_Regexp_Array is array (Positive range <>)
of Pattern_Matcher_Access;
function "+"
(P : GNAT.Regpat.Pattern_Matcher)
return Pattern_Matcher_Access;
-- Allocate some memory for the pattern matcher.
-- This is only a convenience function to help create the array of
-- compiled regular expressoins.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexps : Regexp_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Wait till a string matching one of the regular expressions in Regexps
-- is found. This function returns the index of the regexp that matched.
-- This command is blocking, but will timeout after Timeout milliseconds.
-- In that case, Timeout is returned.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexps : Compiled_Regexp_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as the previous one, but with precompiled regular expressions.
-- This can be much faster if you are using them multiple times.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexps : Regexp_Array;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as above, except that you can also access the parenthesis
-- groups inside the matching regular expression.
-- The first index in Matched must be 0, or Constraint_Error will be
-- raised. The index 0 contains the indexes for the whole string that was
-- matched, the index 1 contains the indexes for the first parentheses
-- pair, and so on.
procedure Expect
(Descriptor : in out Process_Descriptor;
Result : out Expect_Match;
Regexps : Compiled_Regexp_Array;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as above, but with precompiled regular expressions.
-- The first index in Matched must be 0, or Constraint_Error will be
-- raised.
-------------------------------------------
-- Working on the output (multi-process) --
-------------------------------------------
type Multiprocess_Regexp is record
Descriptor : Process_Descriptor_Access;
Regexp : Pattern_Matcher_Access;
end record;
type Multiprocess_Regexp_Array is array (Positive range <>)
of Multiprocess_Regexp;
procedure Expect
(Result : out Expect_Match;
Regexps : Multiprocess_Regexp_Array;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as above, but for multi processes.
procedure Expect
(Result : out Expect_Match;
Regexps : Multiprocess_Regexp_Array;
Timeout : Integer := 10000;
Full_Buffer : Boolean := False);
-- Same as the previous one, but for multiple processes.
-- This procedure finds the first regexp that match the associated process.
------------------------
-- Getting the output --
------------------------
procedure Flush
(Descriptor : in out Process_Descriptor;
Timeout : Integer := 0);
-- Discard all output waiting from the process.
--
-- This output is simply discarded, and no filter is called. This output
-- will also not be visible by the next call to Expect, nor will any
-- output currently buffered.
--
-- Timeout is the delay for which we wait for output to be available from
-- the process. If 0, we only get what is immediately available.
function Expect_Out (Descriptor : Process_Descriptor) return String;
-- Return the string matched by the last Expect call.
--
-- The returned string is in fact the concatenation of all the strings
-- read from the file descriptor up to, and including, the characters
-- that matched the regular expression.
--
-- For instance, with an input "philosophic", and a regular expression
-- "hi" in the call to expect, the strings returned the first and second
-- time would be respectively "phi" and "losophi".
function Expect_Out_Match (Descriptor : Process_Descriptor) return String;
-- Return the string matched by the last Expect call.
--
-- The returned string includes only the character that matched the
-- specific regular expression. All the characters that came before are
-- simply discarded.
--
-- For instance, with an input "philosophic", and a regular expression
-- "hi" in the call to expect, the strings returned the first and second
-- time would both be "hi".
----------------
-- Exceptions --
----------------
Invalid_Process : exception;
-- Raised by most subprograms above when the parameter Descriptor is not a
-- valid process or is a closed process.
Process_Died : exception;
-- Raised by all the expect subprograms if Descriptor was originally a
-- valid process that died while Expect was executing. It is also raised
-- when Expect receives an end-of-file.
------------------------
-- Internal functions --
------------------------
-- The following subprograms are provided so that it is easy to write
-- extensions to this package. However, clients should not use these
-- routines directly.
procedure Portable_Execvp (Cmd : String; Args : System.Address);
-- Executes, in a portable way, the command Cmd (full path must be
-- specified), with the given Args. Note that the first element in Args
-- must be the executable name, and the last element must be a null
-- pointer
private
type Filter_List_Elem;
type Filter_List is access Filter_List_Elem;
type Filter_List_Elem is record
Filter : Filter_Function;
User_Data : System.Address;
Filter_On : Filter_Type;
Next : Filter_List;
end record;
type Pipe_Type is record
Input, Output : GNAT.OS_Lib.File_Descriptor;
end record;
-- This type represents a pipe, used to communicate between two processes.
procedure Set_Up_Communications
(Pid : in out Process_Descriptor;
Err_To_Out : Boolean;
Pipe1 : access Pipe_Type;
Pipe2 : access Pipe_Type;
Pipe3 : access Pipe_Type);
-- Set up all the communication pipes and file descriptors prior to
-- spawning the child process.
procedure Set_Up_Parent_Communications
(Pid : in out Process_Descriptor;
Pipe1 : in out Pipe_Type;
Pipe2 : in out Pipe_Type;
Pipe3 : in out Pipe_Type);
-- Finish the set up of the pipes while in the parent process
procedure Set_Up_Child_Communications
(Pid : in out Process_Descriptor;
Pipe1 : in out Pipe_Type;
Pipe2 : in out Pipe_Type;
Pipe3 : in out Pipe_Type;
Cmd : String;
Args : System.Address);
-- Finish the set up of the pipes while in the child process
-- This also spawns the child process (based on Cmd).
-- On systems that support fork, this procedure is executed inside the
-- newly created process.
type Process_Descriptor is tagged record
Pid : Process_Id := Invalid_Pid;
Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD;
Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD;
Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD;
Filters_Lock : Integer := 0;
Filters : Filter_List := null;
Buffer : GNAT.OS_Lib.String_Access := null;
Buffer_Size : Natural := 0;
Buffer_Index : Natural := 0;
Last_Match_Start : Natural := 0;
Last_Match_End : Natural := 0;
end record;
pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp");
end GNAT.Expect;

63
gcc/ada/g-flocon.ads Normal file
View File

@ -0,0 +1,63 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . F L O A T _ C O N T R O L --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Control functions for floating-point unit
package GNAT.Float_Control is
procedure Reset;
-- Reset the floating-point processor to the default state needed to get
-- correct Ada semantics for the target. Some third party tools change
-- the settings for the floating-point processor. Reset can be called
-- to reset the floating-point processor into the mode required by GNAT
-- for correct operation. Use this call after a call to foreign code if
-- you suspect incorrect floating-point operation after the call.
--
-- For example under Windows NT some system DLL calls change the default
-- FPU arithmetic to 64 bit precision mode. However, since in Ada 95 it
-- is required to provide full access to the floating-point types of the
-- architecture, GNAT requires full 80-bit precision mode, and Reset makes
-- sure this mode is established.
--
-- Similarly on the PPC processor, it is important that overflow and
-- underflow exceptions be disabled.
--
-- The call to Reset simply has no effect if the target environment
-- does not give rise to such concerns.
private
pragma Import (C, Reset, "__gnat_init_float");
end GNAT.Float_Control;

135
gcc/ada/g-hesora.adb Normal file
View File

@ -0,0 +1,135 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ A --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $ --
-- --
-- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Heap_Sort_A is
----------
-- Sort --
----------
-- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3)
-- as described by Knuth ("The Art of Programming", Volume III, first
-- edition, section 5.2.3, p. 145-147) with the modification that is
-- mentioned in exercise 18. For more details on this algorithm, see
-- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray
-- Phase Problem". University of Chicago, 1968, which was the first
-- publication of the modification, which reduces the number of compares
-- from 2NlogN to NlogN.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is
Max : Natural := N;
-- Current Max index in tree being sifted
procedure Sift (S : Positive);
-- This procedure sifts up node S, i.e. converts the subtree rooted
-- at node S into a heap, given the precondition that any sons of
-- S are already heaps. On entry, the contents of node S is found
-- in the temporary (index 0), the actual contents of node S on
-- entry are irrelevant. This is just a minor optimization to avoid
-- what would otherwise be two junk moves in phase two of the sort.
procedure Sift (S : Positive) is
C : Positive := S;
Son : Positive;
Father : Positive;
begin
-- This is where the optimization is done, normally we would do a
-- comparison at each stage between the current node and the larger
-- of the two sons, and continue the sift only if the current node
-- was less than this maximum. In this modified optimized version,
-- we assume that the current node will be less than the larger
-- son, and unconditionally sift up. Then when we get to the bottom
-- of the tree, we check parents to make sure that we did not make
-- a mistake. This roughly cuts the number of comparisions in half,
-- since it is almost always the case that our assumption is correct.
-- Loop to pull up larger sons
loop
Son := 2 * C;
exit when Son > Max;
if Son < Max and then Lt (Son, Son + 1) then
Son := Son + 1;
end if;
Move (Son, C);
C := Son;
end loop;
-- Loop to check fathers
while C /= S loop
Father := C / 2;
if Lt (Father, 0) then
Move (Father, C);
C := Father;
else
exit;
end if;
end loop;
-- Last step is to pop the sifted node into place
Move (0, C);
end Sift;
-- Start of processing for Sort
begin
-- Phase one of heapsort is to build the heap. This is done by
-- sifting nodes N/2 .. 1 in sequence.
for J in reverse 1 .. N / 2 loop
Move (J, 0);
Sift (J);
end loop;
-- In phase 2, the largest node is moved to end, reducing the size
-- of the tree by one, and the displaced node is sifted down from
-- the top, so that the largest node is again at the top.
while Max > 1 loop
Move (Max, 0);
Move (1, Max);
Max := Max - 1;
Sift (1);
end loop;
end Sort;
end GNAT.Heap_Sort_A;

68
gcc/ada/g-hesora.ads Normal file
View File

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ A --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Heapsort using access to procedure parameters
-- This package provides a heapsort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
-- shared sorting code. See also GNAT.Heap_Sort_G, the generic version,
-- which is a little more efficient but does not allow code sharing.
-- The generic version is also Pure, while the access version can
-- only be Preelaborate.
package GNAT.Heap_Sort_A is
pragma Preelaborate (Heap_Sort_A);
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
type Move_Procedure is access procedure (From : Natural; To : Natural);
-- A pointer to a procedure that moves the data item with index From to
-- the data item with index To. An index value of zero is used for moves
-- from and to the single temporary location used by the sort.
type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
-- A pointer to a function that compares two items and returns True if
-- the item with index Op1 is less than the item with index Op2, and False
-- if the Op1 item is greater than or equal to the Op2 item.
procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Heap_Sort_A;

135
gcc/ada/g-hesorg.adb Normal file
View File

@ -0,0 +1,135 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ G --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Heap_Sort_G is
----------
-- Sort --
----------
-- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3)
-- as described by Knuth ("The Art of Programming", Volume III, first
-- edition, section 5.2.3, p. 145-147) with the modification that is
-- mentioned in exercise 18. For more details on this algorithm, see
-- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray
-- Phase Problem". University of Chicago, 1968, which was the first
-- publication of the modification, which reduces the number of compares
-- from 2NlogN to NlogN.
procedure Sort (N : Natural) is
Max : Natural := N;
-- Current Max index in tree being sifted
procedure Sift (S : Positive);
-- This procedure sifts up node S, i.e. converts the subtree rooted
-- at node S into a heap, given the precondition that any sons of
-- S are already heaps. On entry, the contents of node S is found
-- in the temporary (index 0), the actual contents of node S on
-- entry are irrelevant. This is just a minor optimization to avoid
-- what would otherwise be two junk moves in phase two of the sort.
procedure Sift (S : Positive) is
C : Positive := S;
Son : Positive;
Father : Positive;
begin
-- This is where the optimization is done, normally we would do a
-- comparison at each stage between the current node and the larger
-- of the two sons, and continue the sift only if the current node
-- was less than this maximum. In this modified optimized version,
-- we assume that the current node will be less than the larger
-- son, and unconditionally sift up. Then when we get to the bottom
-- of the tree, we check parents to make sure that we did not make
-- a mistake. This roughly cuts the number of comparisions in half,
-- since it is almost always the case that our assumption is correct.
-- Loop to pull up larger sons
loop
Son := 2 * C;
exit when Son > Max;
if Son < Max and then Lt (Son, Son + 1) then
Son := Son + 1;
end if;
Move (Son, C);
C := Son;
end loop;
-- Loop to check fathers
while C /= S loop
Father := C / 2;
if Lt (Father, 0) then
Move (Father, C);
C := Father;
else
exit;
end if;
end loop;
-- Last step is to pop the sifted node into place
Move (0, C);
end Sift;
-- Start of processing for Sort
begin
-- Phase one of heapsort is to build the heap. This is done by
-- sifting nodes N/2 .. 1 in sequence.
for J in reverse 1 .. N / 2 loop
Move (J, 0);
Sift (J);
end loop;
-- In phase 2, the largest node is moved to end, reducing the size
-- of the tree by one, and the displaced node is sifted down from
-- the top, so that the largest node is again at the top.
while Max > 1 loop
Move (Max, 0);
Move (1, Max);
Max := Max - 1;
Sift (1);
end loop;
end Sort;
end GNAT.Heap_Sort_G;

68
gcc/ada/g-hesorg.ads Normal file
View File

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H E A P _ S O R T _ G --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Heapsort generic package using formal procedures
-- This package provides a generic heapsort routine that can be used with
-- different types of data. See also GNAT.Heap_Sort_A, a version that works
-- with subprogram parameters, allowing code sharing. The generic version
-- is slightly more efficient but does not allow code sharing. The generic
-- version is also Pure, while the access version can only be Preelaborate.
generic
-- The data to be sorted is assumed to be indexed by integer values from
-- 1 to N, where N is the number of items to be sorted. In addition, the
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
-- A procedure that moves the data item with index From to the data item
-- with Index To. An index value of zero is used for moves from and to a
-- single temporary location used by the sort.
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
-- index Op1 is less than the item with Index Op2, and False if the Op1
-- item is greater than or equal to the Op2 item.
package GNAT.Heap_Sort_G is
pragma Pure (Heap_Sort_G);
procedure Sort (N : Natural);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
-- single temporary location with index value zero. This sort is not
-- stable, i.e. the order of equal elements in the input is not preserved.
end GNAT.Heap_Sort_G;

362
gcc/ada/g-htable.adb Normal file
View File

@ -0,0 +1,362 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H T A B L E --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
package body GNAT.HTable is
--------------------
-- Static_HTable --
--------------------
package body Static_HTable is
Table : array (Header_Num) of Elmt_Ptr;
Iterator_Index : Header_Num;
Iterator_Ptr : Elmt_Ptr;
Iterator_Started : Boolean := False;
function Get_Non_Null return Elmt_Ptr;
-- Returns Null_Ptr if Iterator_Started is false of the Table is
-- empty. Returns Iterator_Ptr if non null, or the next non null
-- element in table if any.
---------
-- Get --
---------
function Get (K : Key) return Elmt_Ptr is
Elmt : Elmt_Ptr;
begin
Elmt := Table (Hash (K));
loop
if Elmt = Null_Ptr then
return Null_Ptr;
elsif Equal (Get_Key (Elmt), K) then
return Elmt;
else
Elmt := Next (Elmt);
end if;
end loop;
end Get;
---------------
-- Get_First --
---------------
function Get_First return Elmt_Ptr is
begin
Iterator_Started := True;
Iterator_Index := Table'First;
Iterator_Ptr := Table (Iterator_Index);
return Get_Non_Null;
end Get_First;
--------------
-- Get_Next --
--------------
function Get_Next return Elmt_Ptr is
begin
if not Iterator_Started then
return Null_Ptr;
end if;
Iterator_Ptr := Next (Iterator_Ptr);
return Get_Non_Null;
end Get_Next;
------------------
-- Get_Non_Null --
------------------
function Get_Non_Null return Elmt_Ptr is
begin
while Iterator_Ptr = Null_Ptr loop
if Iterator_Index = Table'Last then
Iterator_Started := False;
return Null_Ptr;
end if;
Iterator_Index := Iterator_Index + 1;
Iterator_Ptr := Table (Iterator_Index);
end loop;
return Iterator_Ptr;
end Get_Non_Null;
------------
-- Remove --
------------
procedure Remove (K : Key) is
Index : constant Header_Num := Hash (K);
Elmt : Elmt_Ptr;
Next_Elmt : Elmt_Ptr;
begin
Elmt := Table (Index);
if Elmt = Null_Ptr then
return;
elsif Equal (Get_Key (Elmt), K) then
Table (Index) := Next (Elmt);
else
loop
Next_Elmt := Next (Elmt);
if Next_Elmt = Null_Ptr then
return;
elsif Equal (Get_Key (Next_Elmt), K) then
Set_Next (Elmt, Next (Next_Elmt));
return;
else
Elmt := Next_Elmt;
end if;
end loop;
end if;
end Remove;
-----------
-- Reset --
-----------
procedure Reset is
begin
for J in Table'Range loop
Table (J) := Null_Ptr;
end loop;
end Reset;
---------
-- Set --
---------
procedure Set (E : Elmt_Ptr) is
Index : Header_Num;
begin
Index := Hash (Get_Key (E));
Set_Next (E, Table (Index));
Table (Index) := E;
end Set;
end Static_HTable;
--------------------
-- Simple_HTable --
--------------------
package body Simple_HTable is
type Element_Wrapper;
type Elmt_Ptr is access all Element_Wrapper;
type Element_Wrapper is record
K : Key;
E : Element;
Next : Elmt_Ptr;
end record;
procedure Free is new
Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
function Next (E : Elmt_Ptr) return Elmt_Ptr;
function Get_Key (E : Elmt_Ptr) return Key;
package Tab is new Static_HTable (
Header_Num => Header_Num,
Element => Element_Wrapper,
Elmt_Ptr => Elmt_Ptr,
Null_Ptr => null,
Set_Next => Set_Next,
Next => Next,
Key => Key,
Get_Key => Get_Key,
Hash => Hash,
Equal => Equal);
---------
-- Get --
---------
function Get (K : Key) return Element is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get;
---------------
-- Get_First --
---------------
function Get_First return Element is
Tmp : constant Elmt_Ptr := Tab.Get_First;
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get_First;
-------------
-- Get_Key --
-------------
function Get_Key (E : Elmt_Ptr) return Key is
begin
return E.K;
end Get_Key;
--------------
-- Get_Next --
--------------
function Get_Next return Element is
Tmp : constant Elmt_Ptr := Tab.Get_Next;
begin
if Tmp = null then
return No_Element;
else
return Tmp.E;
end if;
end Get_Next;
----------
-- Next --
----------
function Next (E : Elmt_Ptr) return Elmt_Ptr is
begin
return E.Next;
end Next;
------------
-- Remove --
------------
procedure Remove (K : Key) is
Tmp : Elmt_Ptr;
begin
Tmp := Tab.Get (K);
if Tmp /= null then
Tab.Remove (K);
Free (Tmp);
end if;
end Remove;
-----------
-- Reset --
-----------
procedure Reset is
E1, E2 : Elmt_Ptr;
begin
E1 := Tab.Get_First;
while E1 /= null loop
E2 := Tab.Get_Next;
Free (E1);
E1 := E2;
end loop;
Tab.Reset;
end Reset;
---------
-- Set --
---------
procedure Set (K : Key; E : Element) is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
Tab.Set (new Element_Wrapper'(K, E, null));
else
Tmp.E := E;
end if;
end Set;
--------------
-- Set_Next --
--------------
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
begin
E.Next := Next;
end Set_Next;
end Simple_HTable;
----------
-- Hash --
----------
function Hash (Key : String) return Header_Num is
type Uns is mod 2 ** 32;
function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
pragma Import (Intrinsic, Rotate_Left);
Tmp : Uns := 0;
begin
for J in Key'Range loop
Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
end loop;
return Header_Num'First +
Header_Num'Base (Tmp mod Header_Num'Range_Length);
end Hash;
end GNAT.HTable;

192
gcc/ada/g-htable.ads Normal file
View File

@ -0,0 +1,192 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . H T A B L E --
-- --
-- S p e c --
-- --
-- $Revision: 1.19 $
-- --
-- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Hash table searching routines
-- This package contains two separate packages. The Simple_Htable package
-- provides a very simple abstraction that asosicates one element to one
-- key values and takes care of all allocation automatically using the heap.
-- The Static_Htable package provides a more complex interface that allows
-- complete control over allocation.
package GNAT.HTable is
pragma Preelaborate (HTable);
-------------------
-- Simple_HTable --
-------------------
-- A simple hash table abstraction, easy to instantiate, easy to use.
-- The table associates one element to one key with the procedure Set.
-- Get retrieves the Element stored for a given Key. The efficiency of
-- retrieval is function of the size of the Table parameterized by
-- Header_Num and the hashing function Hash.
generic
type Header_Num is range <>;
-- An integer type indicating the number and range of hash headers.
type Element is private;
-- The type of element to be stored
No_Element : Element;
-- The object that is returned by Get when no element has been set for
-- a given key
type Key is private;
with function Hash (F : Key) return Header_Num;
with function Equal (F1, F2 : Key) return Boolean;
package Simple_HTable is
procedure Set (K : Key; E : Element);
-- Associates an element with a given key. Overrides any previously
-- associated element.
procedure Reset;
-- Removes and frees all elements in the table
function Get (K : Key) return Element;
-- Returns the Element associated with a key or No_Element if the
-- given key has not associated element
procedure Remove (K : Key);
-- Removes the latest inserted element pointer associated with the
-- given key if any, does nothing if none.
function Get_First return Element;
-- Returns No_Element if the Htable is empty, otherwise returns one
-- non specified element. There is no guarantee that 2 calls to this
-- function will return the same element.
function Get_Next return Element;
-- Returns a non-specified element that has not been returned by the
-- same function since the last call to Get_First or No_Element if
-- there is no such element. If there is no call to 'Set' in between
-- Get_Next calls, all the elements of the Htable will be traversed.
end Simple_HTable;
-------------------
-- Static_HTable --
-------------------
-- A low-level Hash-Table abstraction, not as easy to instantiate as
-- Simple_HTable but designed to allow complete control over the
-- allocation of necessary data structures. Particularly useful when
-- dynamic allocation is not desired. The model is that each Element
-- contains its own Key that can be retrieved by Get_Key. Furthermore,
-- Element provides a link that can be used by the HTable for linking
-- elements with same hash codes:
-- Element
-- +-------------------+
-- | Key |
-- +-------------------+
-- : other data :
-- +-------------------+
-- | Next Elmt |
-- +-------------------+
generic
type Header_Num is range <>;
-- An integer type indicating the number and range of hash headers.
type Element (<>) is limited private;
-- The type of element to be stored
type Elmt_Ptr is private;
-- The type used to reference an element (will usually be an access
-- type, but could be some other form of type such as an integer type).
Null_Ptr : Elmt_Ptr;
-- The null value of the Elmt_Ptr type.
with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
with function Next (E : Elmt_Ptr) return Elmt_Ptr;
-- The type must provide an internal link for the sake of the
-- staticness of the HTable.
type Key is limited private;
with function Get_Key (E : Elmt_Ptr) return Key;
with function Hash (F : Key) return Header_Num;
with function Equal (F1, F2 : Key) return Boolean;
package Static_HTable is
procedure Reset;
-- Resets the hash table by setting all its elements to Null_Ptr. The
-- effect is to clear the hash table so that it can be reused. For the
-- most common case where Elmt_Ptr is an access type, and Null_Ptr is
-- null, this is only needed if the same table is reused in a new
-- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
-- other than null, then Reset must be called before the first use
-- of the hash table.
procedure Set (E : Elmt_Ptr);
-- Insert the element pointer in the HTable
function Get (K : Key) return Elmt_Ptr;
-- Returns the latest inserted element pointer with the given Key
-- or null if none.
procedure Remove (K : Key);
-- Removes the latest inserted element pointer associated with the
-- given key if any, does nothing if none.
function Get_First return Elmt_Ptr;
-- Returns Null_Ptr if the Htable is empty, otherwise returns one
-- non specified element. There is no guarantee that 2 calls to this
-- function will return the same element.
function Get_Next return Elmt_Ptr;
-- Returns a non-specified element that has not been returned by the
-- same function since the last call to Get_First or Null_Ptr if
-- there is no such element or Get_First has bever been called. If
-- there is no call to 'Set' in between Get_Next calls, all the
-- elements of the Htable will be traversed.
end Static_HTable;
----------
-- Hash --
----------
-- A generic hashing function working on String keys
generic
type Header_Num is range <>;
function Hash (Key : String) return Header_Num;
end GNAT.HTable;

200
gcc/ada/g-io.adb Normal file
View File

@ -0,0 +1,200 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.IO is
Current_Out : File_Type := Stdout;
pragma Atomic (Current_Out);
-- Current output file (modified by Set_Output)
---------
-- Get --
---------
procedure Get (X : out Integer) is
function Get_Int return Integer;
pragma Import (C, Get_Int, "get_int");
begin
X := Get_Int;
end Get;
procedure Get (C : out Character) is
function Get_Char return Character;
pragma Import (C, Get_Char, "get_char");
begin
C := Get_Char;
end Get;
--------------
-- Get_Line --
--------------
procedure Get_Line (Item : in out String; Last : out Natural) is
C : Character;
begin
for Nstore in Item'Range loop
Get (C);
if C = ASCII.LF then
Last := Nstore - 1;
return;
else
Item (Nstore) := C;
end if;
end loop;
Last := Item'Last;
end Get_Line;
--------------
-- New_Line --
--------------
procedure New_Line (File : File_Type; Spacing : Positive := 1) is
begin
for J in 1 .. Spacing loop
Put (File, ASCII.LF);
end loop;
end New_Line;
procedure New_Line (Spacing : Positive := 1) is
begin
New_Line (Current_Out, Spacing);
end New_Line;
---------
-- Put --
---------
procedure Put (X : Integer) is
begin
Put (Current_Out, X);
end Put;
procedure Put (File : File_Type; X : Integer) is
procedure Put_Int (X : Integer);
pragma Import (C, Put_Int, "put_int");
procedure Put_Int_Stderr (X : Integer);
pragma Import (C, Put_Int_Stderr, "put_int_stderr");
begin
case File is
when Stdout => Put_Int (X);
when Stderr => Put_Int_Stderr (X);
end case;
end Put;
procedure Put (C : Character) is
begin
Put (Current_Out, C);
end Put;
procedure Put (File : in File_Type; C : Character) is
procedure Put_Char (C : Character);
pragma Import (C, Put_Char, "put_char");
procedure Put_Char_Stderr (C : Character);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
case File is
when Stdout => Put_Char (C);
when Stderr => Put_Char_Stderr (C);
end case;
end Put;
procedure Put (S : String) is
begin
Put (Current_Out, S);
end Put;
procedure Put (File : File_Type; S : String) is
begin
for J in S'Range loop
Put (File, S (J));
end loop;
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (S : String) is
begin
Put_Line (Current_Out, S);
end Put_Line;
procedure Put_Line (File : File_Type; S : String) is
begin
Put (File, S);
New_Line (File);
end Put_Line;
----------------
-- Set_Output --
----------------
procedure Set_Output (File : in File_Type) is
begin
Current_Out := File;
end Set_Output;
---------------------
-- Standard_Output --
---------------------
function Standard_Output return File_Type is
begin
return Stdout;
end Standard_Output;
--------------------
-- Standard_Error --
--------------------
function Standard_Error return File_Type is
begin
return Stderr;
end Standard_Error;
end GNAT.IO;

94
gcc/ada/g-io.ads Normal file
View File

@ -0,0 +1,94 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- A simple preelaborable subset of Text_IO capabilities
-- A simple text I/O package that can be used for simple I/O functions in
-- user programs as required. This package is also preelaborated, unlike
-- Text_Io, and can thus be with'ed by preelaborated library units.
-- Note that Data_Error is not raised by these subprograms for bad data.
-- If such checks are needed then the regular Text_IO package such be used.
package GNAT.IO is
pragma Preelaborate (IO);
type File_Type is limited private;
-- Specifies file to be used (the only possibilities are Standard_Output
-- and Standard_Error). There is no Create or Open facility that would
-- allow more general use of file names.
function Standard_Output return File_Type;
function Standard_Error return File_Type;
-- These functions are the only way to get File_Type values
procedure Get (X : out Integer);
procedure Get (C : out Character);
procedure Get_Line (Item : in out String; Last : out Natural);
-- These routines always read from Standard_Input
procedure Put (File : File_Type; X : Integer);
procedure Put (X : Integer);
-- Output integer to specified file, or to current output file, same
-- output as if Ada.Text_IO.Integer_IO had been instantiated for Integer.
procedure Put (File : File_Type; C : Character);
procedure Put (C : Character);
-- Output character to specified file, or to current output file
procedure Put (File : File_Type; S : String);
procedure Put (S : String);
-- Output string to specified file, or to current output file
procedure Put_Line (File : File_Type; S : String);
procedure Put_Line (S : String);
-- Output string followed by new line to specified file, or to
-- current output file.
procedure New_Line (File : File_Type; Spacing : Positive := 1);
procedure New_Line (Spacing : Positive := 1);
-- Output new line character to specified file, or to current output file
procedure Set_Output (File : File_Type);
-- Set current output file, default is Standard_Output if no call to
-- Set_Output is made.
private
type File_Type is (Stdout, Stderr);
-- Stdout = Standard_Output, Stderr = Standard_Error
pragma Inline (Standard_Error);
pragma Inline (Standard_Output);
end GNAT.IO;

108
gcc/ada/g-io_aux.adb Normal file
View File

@ -0,0 +1,108 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O _ A U X --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Interfaces.C_Streams; use Interfaces.C_Streams;
package body GNAT.IO_Aux is
Buflen : constant := 2000;
-- Buffer length. Works for any non-zero value, larger values take
-- more stack space, smaller values require more recursion.
-----------------
-- File_Exists --
-----------------
function File_Exists (Name : String) return Boolean
is
Namestr : aliased String (1 .. Name'Length + 1);
-- Name as given with ASCII.NUL appended
begin
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
return file_exists (Namestr'Address) /= 0;
end File_Exists;
--------------
-- Get_Line --
--------------
-- Current_Input case
function Get_Line return String is
Buffer : String (1 .. Buflen);
-- Buffer to read in chunks of remaining line. Will work with any
-- size buffer. We choose a length so that most of the time no
-- recursion will be required.
Last : Natural;
begin
Ada.Text_IO.Get_Line (Buffer, Last);
-- If the buffer is not full, then we are all done
if Last < Buffer'Last then
return Buffer (1 .. Last);
-- Otherwise, we still have characters left on the line. Note that
-- as specified by (RM A.10.7(19)) the end of line is not skipped
-- in this case, even if we are right at it now.
else
return Buffer & GNAT.IO_Aux.Get_Line;
end if;
end Get_Line;
-- Case of reading from a specified file. Note that we could certainly
-- share code between these two versions, but these are very short
-- routines, and we may as well aim for maximum speed, cutting out an
-- intermediate call (calls returning string may be somewhat slow)
function Get_Line (File : Ada.Text_IO.File_Type) return String is
Buffer : String (1 .. Buflen);
Last : Natural;
begin
Ada.Text_IO.Get_Line (File, Buffer, Last);
if Last < Buffer'Last then
return Buffer (1 .. Last);
else
return Buffer & Get_Line (File);
end if;
end Get_Line;
end GNAT.IO_Aux;

57
gcc/ada/g-io_aux.ads Normal file
View File

@ -0,0 +1,57 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . I O _ A U X --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Auxiliary functions or use with Text_IO
-- This package provides some auxiliary functions for use with Text_IO,
-- including a test for an existing file, and a Get_Line function which
-- returns a string.
with Ada.Text_IO;
package GNAT.IO_Aux is
function File_Exists (Name : String) return Boolean;
-- Test for existence of a file named Name
function Get_Line return String;
-- Read Ada.Text_IO.Current_Input and return string that includes all
-- characters from the current character up to the end of the line,
-- with no limit on its length. Raises Ada.IO_Exceptions.End_Error if
-- at end of file.
function Get_Line (File : Ada.Text_IO.File_Type) return String;
-- Same, but reads from specified file
end GNAT.IO_Aux;

116
gcc/ada/g-locfil.adb Normal file
View File

@ -0,0 +1,116 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . L O C K _ F I L E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1998-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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System;
package body GNAT.Lock_Files is
Dir_Separator : Character;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
---------------
-- Lock_File --
---------------
procedure Lock_File
(Directory : String;
Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last)
is
Dir : aliased String := Directory & ASCII.NUL;
File : aliased String := Lock_File_Name & ASCII.NUL;
function Try_Lock (Dir, File : System.Address) return Integer;
pragma Import (C, Try_Lock, "__gnat_try_lock");
begin
for I in 0 .. Retries loop
if Try_Lock (Dir'Address, File'Address) = 1 then
return;
end if;
exit when I = Retries;
delay Wait;
end loop;
raise Lock_Error;
end Lock_File;
---------------
-- Lock_File --
---------------
procedure Lock_File
(Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last)
is
begin
for J in reverse Lock_File_Name'Range loop
if Lock_File_Name (J) = Dir_Separator then
Lock_File
(Lock_File_Name (Lock_File_Name'First .. J - 1),
Lock_File_Name (J + 1 .. Lock_File_Name'Last),
Wait,
Retries);
return;
end if;
end loop;
Lock_File (".", Lock_File_Name, Wait, Retries);
end Lock_File;
-----------------
-- Unlock_File --
-----------------
procedure Unlock_File (Lock_File_Name : String) is
S : aliased String := Lock_File_Name & ASCII.NUL;
procedure unlink (A : System.Address);
pragma Import (C, unlink, "unlink");
begin
unlink (S'Address);
end Unlock_File;
-----------------
-- Unlock_File --
-----------------
procedure Unlock_File (Directory : String; Lock_File_Name : String) is
begin
Unlock_File (Directory & Dir_Separator & Lock_File_Name);
end Unlock_File;
end GNAT.Lock_Files;

67
gcc/ada/g-locfil.ads Normal file
View File

@ -0,0 +1,67 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . L O C K _ F I L E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the necessary routines for using files for the
-- purpose of providing realiable system wide locking capability.
package GNAT.Lock_Files is
pragma Preelaborate;
Lock_Error : exception;
-- Exception raised if file cannot be locked
procedure Lock_File
(Directory : String;
Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last);
-- Create a lock file Lock_File_Name in directory Directory. If the file
-- cannot be locked because someone already owns the lock, this procedure
-- waits Wait seconds and retries at most Retries times. If the file
-- still cannot be locked, Lock_Error is raised. The default is to try
-- every second, almost forever (Natural'Last times).
procedure Lock_File
(Lock_File_Name : String;
Wait : Duration := 1.0;
Retries : Natural := Natural'Last);
-- See above. The full lock file path is given as one string.
procedure Unlock_File (Directory : String; Lock_File_Name : String);
-- Unlock a file
procedure Unlock_File (Lock_File_Name : String);
-- Unlock a file whose full path is given in Lock_File_Name
end GNAT.Lock_Files;

85
gcc/ada/g-moreex.adb Normal file
View File

@ -0,0 +1,85 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions.Is_Null_Occurrence;
with System.Soft_Links;
package body GNAT.Most_Recent_Exception is
----------------
-- Occurrence --
----------------
function Occurrence
return Ada.Exceptions.Exception_Occurrence
is
EOA : constant Ada.Exceptions.Exception_Occurrence_Access :=
GNAT.Most_Recent_Exception.Occurrence_Access;
use type Ada.Exceptions.Exception_Occurrence_Access;
begin
if EOA = null then
return Ada.Exceptions.Null_Occurrence;
else
return EOA.all;
end if;
end Occurrence;
-----------------------
-- Occurrence_Access --
-----------------------
function Occurrence_Access
return Ada.Exceptions.Exception_Occurrence_Access
is
use Ada.Exceptions;
EOA : constant Exception_Occurrence_Access :=
System.Soft_Links.Get_Current_Excep.all;
begin
if EOA = null then
return null;
elsif Is_Null_Occurrence (EOA.all) then
return null;
else
return EOA;
end if;
end Occurrence_Access;
end GNAT.Most_Recent_Exception;

79
gcc/ada/g-moreex.ads Normal file
View File

@ -0,0 +1,79 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides routines for accessing the most recently raised
-- exception. This may be useful for certain logging activities. It may
-- also be useful for mimicing implementation dependent capabilities in
-- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage.
with Ada.Exceptions;
package GNAT.Most_Recent_Exception is
-----------------
-- Subprograms --
-----------------
function Occurrence
return Ada.Exceptions.Exception_Occurrence;
-- Returns the Exception_Occurrence for the most recently raised
-- exception in the current task. If no exception has been raised
-- in the current task prior to the call, returns Null_Occurrence.
function Occurrence_Access
return Ada.Exceptions.Exception_Occurrence_Access;
-- Similar to the above, but returns an access to the occurrence value.
-- This value is in a task specific location, and may be validly accessed
-- as long as no further exception is raised in the calling task.
-- Note: unlike the routines in GNAT.Current_Exception, these functions
-- access the most recently raised exception, regardless of where they
-- are called. Consider the following example:
-- exception
-- when Constraint_Error =>
-- begin
-- ...
-- exception
-- when Tasking_Error => ...
-- end;
--
-- -- Assuming a Tasking_Error was raised in the inner block,
-- -- a call to GNAT.Most_Recent_Exception.Occurrence will
-- -- return information about this Tasking_Error exception,
-- -- not about the Constraint_Error exception being handled
-- -- by the current handler code.
end GNAT.Most_Recent_Exception;

1347
gcc/ada/g-os_lib.adb Normal file
View File

File diff suppressed because it is too large Load Diff

512
gcc/ada/g-os_lib.ads Normal file
View File

@ -0,0 +1,512 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . O S _ L I B --
-- --
-- S p e c --
-- --
-- $Revision: 1.79 $
-- --
-- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Operating system interface facilities
-- This package contains types and procedures for interfacing to the
-- underlying OS. It is used by the GNAT compiler and by tools associated
-- with the GNAT compiler, and therefore works for the various operating
-- systems to which GNAT has been ported. This package will undoubtedly
-- grow as new services are needed by various tools.
-- This package tends to use fairly low-level Ada in order to not bring
-- in large portions of the RTL. For example, functions return access
-- to string as part of avoiding functions returning unconstrained types;
-- types related to dates are defined here instead of using the types
-- from Calendar, since use of Calendar forces linking in of tasking code.
-- Except where specifically noted, these routines are portable across
-- all GNAT implementations on all supported operating systems.
with System;
with Unchecked_Deallocation;
package GNAT.OS_Lib is
pragma Elaborate_Body (OS_Lib);
type String_Access is access all String;
procedure Free is new Unchecked_Deallocation
(Object => String, Name => String_Access);
---------------------
-- Time/Date Stuff --
---------------------
-- The OS's notion of time is represented by the private type OS_Time.
-- This is the type returned by the File_Time_Stamp functions to obtain
-- the time stamp of a specified file. Functions and a procedure (modeled
-- after the similar subprograms in package Calendar) are provided for
-- extracting information from a value of this type. Although these are
-- called GM, the intention is not that they provide GMT times in all
-- cases but rather the actual (time-zone independent) time stamp of the
-- file (of course in Unix systems, this *is* in GMT form).
type OS_Time is private;
subtype Year_Type is Integer range 1900 .. 2099;
subtype Month_Type is Integer range 1 .. 12;
subtype Day_Type is Integer range 1 .. 31;
subtype Hour_Type is Integer range 0 .. 23;
subtype Minute_Type is Integer range 0 .. 59;
subtype Second_Type is Integer range 0 .. 59;
function GM_Year (Date : OS_Time) return Year_Type;
function GM_Month (Date : OS_Time) return Month_Type;
function GM_Day (Date : OS_Time) return Day_Type;
function GM_Hour (Date : OS_Time) return Hour_Type;
function GM_Minute (Date : OS_Time) return Minute_Type;
function GM_Second (Date : OS_Time) return Second_Type;
procedure GM_Split
(Date : OS_Time;
Year : out Year_Type;
Month : out Month_Type;
Day : out Day_Type;
Hour : out Hour_Type;
Minute : out Minute_Type;
Second : out Second_Type);
----------------
-- File Stuff --
----------------
-- These routines give access to the open/creat/close/read/write level
-- of I/O routines in the typical C library (these functions are not
-- part of the ANSI C standard, but are typically available in all
-- systems). See also package Interfaces.C_Streams for access to the
-- stream level routines.
-- Note on file names. If a file name is passed as type String in any
-- of the following specifications, then the name is a normal Ada string
-- and need not be NUL-terminated. However, a trailing NUL character is
-- permitted, and will be ignored (more accurately, the NUL and any
-- characters that follow it will be ignored).
type File_Descriptor is private;
-- Corresponds to the int file handle values used in the C routines,
Standin : constant File_Descriptor;
Standout : constant File_Descriptor;
Standerr : constant File_Descriptor;
-- File descriptors for standard input output files
Invalid_FD : constant File_Descriptor;
-- File descriptor returned when error in opening/creating file;
type Mode is (Binary, Text);
for Mode'Size use Integer'Size;
for Mode use (Binary => 0, Text => 1);
-- Used in all the Open and Create calls to specify if the file is to be
-- opened in binary mode or text mode. In systems like Unix, this has no
-- effect, but in systems capable of text mode translation, the use of
-- Text as the mode parameter causes the system to do CR/LF translation
-- and also to recognize the DOS end of file character on input. The use
-- of Text where appropriate allows programs to take a portable Unix view
-- of DOs-format files and process them appropriately.
function Open_Read
(Name : String;
Fmode : Mode)
return File_Descriptor;
-- Open file Name for reading, returning file descriptor File descriptor
-- returned is Invalid_FD if file cannot be opened.
function Open_Read_Write
(Name : String;
Fmode : Mode)
return File_Descriptor;
-- Open file Name for both reading and writing, returning file
-- descriptor. File descriptor returned is Invalid_FD if file cannot be
-- opened.
function Create_File
(Name : String;
Fmode : Mode)
return File_Descriptor;
-- Creates new file with given name for writing, returning file descriptor
-- for subsequent use in Write calls. File descriptor returned is
-- Invalid_FD if file cannot be successfully created
function Create_New_File
(Name : String;
Fmode : Mode)
return File_Descriptor;
-- Create new file with given name for writing, returning file descriptor
-- for subsequent use in Write calls. This differs from Create_File in
-- that it fails if the file already exists. File descriptor returned is
-- Invalid_FD if the file exists or cannot be created.
Temp_File_Len : constant Integer := 12;
-- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL)
subtype Temp_File_Name is String (1 .. Temp_File_Len);
-- String subtype set by Create_Temp_File
procedure Create_Temp_File
(FD : out File_Descriptor;
Name : out Temp_File_Name);
-- Create and open for writing a temporary file. The name of the
-- file and the File Descriptor are returned. The File Descriptor
-- returned is Invalid_FD in the case of failure. No mode parameter
-- is provided. Since this is a temporary file, there is no point in
-- doing text translation on it.
procedure Close (FD : File_Descriptor);
pragma Import (C, Close, "close");
-- Close file referenced by FD
procedure Delete_File (Name : String; Success : out Boolean);
-- Deletes file. Success is set True or False indicating if the delete is
-- successful.
procedure Rename_File
(Old_Name : String;
New_Name : String;
Success : out Boolean);
-- Rename a file. Successis set True or False indicating if the rename is
-- successful.
function Read
(FD : File_Descriptor;
A : System.Address;
N : Integer)
return Integer;
pragma Import (C, Read, "read");
-- Read N bytes to address A from file referenced by FD. Returned value
-- is count of bytes actually read, which can be less than N at EOF.
function Write
(FD : File_Descriptor;
A : System.Address;
N : Integer)
return Integer;
pragma Import (C, Write, "write");
-- Write N bytes from address A to file referenced by FD. The returned
-- value is the number of bytes written, which can be less than N if
-- a disk full condition was detected.
Seek_Cur : constant := 1;
Seek_End : constant := 2;
Seek_Set : constant := 0;
-- Used to indicate origin for Lseek call
procedure Lseek
(FD : File_Descriptor;
offset : Long_Integer;
origin : Integer);
pragma Import (C, Lseek, "lseek");
-- Sets the current file pointer to the indicated offset value,
-- relative to the current position (origin = SEEK_CUR), end of
-- file (origin = SEEK_END), or start of file (origin = SEEK_SET).
function File_Length (FD : File_Descriptor) return Long_Integer;
pragma Import (C, File_Length, "__gnat_file_length");
-- Get length of file from file descriptor FD
function File_Time_Stamp (Name : String) return OS_Time;
-- Given the name of a file or directory, Name, obtains and returns the
-- time stamp. This function can be used for an unopend file.
function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
-- Get time stamp of file from file descriptor FD
function Normalize_Pathname
(Name : String;
Directory : String := "")
return String;
-- Returns a file name as an absolute path name, resolving all relative
-- directories, and symbolic links. The parameter Directory is a fully
-- resolved path name for a directory, or the empty string (the default).
-- Name is the name of a file, which is either relative to the given
-- directory name, if Directory is non-null, or to the current working
-- directory if Directory is null. The result returned is the normalized
-- name of the file. For most cases, if two file names designate the same
-- file through different paths, Normalize_Pathname will return the same
-- canonical name in both cases. However, there are cases when this is
-- not true; for example, this is not true in Unix for two hard links
-- designating the same file.
--
-- If Name cannot be resolved or is null on entry (for example if there is
-- a circularity in symbolic links: A is a symbolic link for B, while B is
-- a symbolic link for A), then Normalize_Pathname returns an empty string.
--
-- In VMS, if Name follows the VMS syntax file specification, it is first
-- converted into Unix syntax. If the conversion fails, Normalize_Pathname
-- returns an empty string.
function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates
-- a directory absolutely, rather than relative to another directory.
function Is_Regular_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
-- regular file. Returns True if so, False otherwise.
function Is_Directory (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of a directory.
-- Returns True if so, False otherwise.
function Is_Writable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
-- file that is writable. Returns True if so, False otherwise.
function Locate_Exec_On_Path
(Exec_Name : String)
return String_Access;
-- Try to locate an executable whose name is given by Exec_Name in the
-- directories listed in the environment Path. If the Exec_Name doesn't
-- have the executable suffix, it will be appended before the search.
-- Otherwise works like Locate_Regular_File below.
--
-- Note that this function allocates some memory for the returned value.
-- This memory needs to be deallocated after use.
function Locate_Regular_File
(File_Name : String;
Path : String)
return String_Access;
-- Try to locate a regular file whose name is given by File_Name in the
-- directories listed in Path. If a file is found, its full pathname is
-- returned; otherwise, a null pointer is returned. If the File_Name given
-- is an absolute pathname, then Locate_Regular_File just checks that the
-- file exists and is a regular file. Otherwise, the Path argument is
-- parsed according to OS conventions, and for each directory in the Path
-- a check is made if File_Name is a relative pathname of a regular file
-- from that directory.
--
-- Note that this function allocates some memory for the returned value.
-- This memory needs to be deallocated after use.
function Get_Debuggable_Suffix return String_Access;
-- Return the debuggable suffix convention. Usually this is the same as
-- the convention for Get_Executable_Suffix.
--
-- Note that this function allocates some memory for the returned value.
-- This memory needs to be deallocated after use.
function Get_Executable_Suffix return String_Access;
-- Return the executable suffix convention.
--
-- Note that this function allocates some memory for the returned value.
-- This memory needs to be deallocated after use.
function Get_Object_Suffix return String_Access;
-- Return the object suffix convention.
--
-- Note that this function allocates some memory for the returned value.
-- This memory needs to be deallocated after use.
-- The following section contains low-level routines using addresses to
-- pass file name and executable name. In each routine the name must be
-- Nul-Terminated. For complete documentation refer to the equivalent
-- routine (but using string) defined above.
subtype C_File_Name is System.Address;
-- This subtype is used to document that a parameter is the address
-- of a null-terminated string containing the name of a file.
function Open_Read
(Name : C_File_Name;
Fmode : Mode)
return File_Descriptor;
function Open_Read_Write
(Name : C_File_Name;
Fmode : Mode)
return File_Descriptor;
function Create_File
(Name : C_File_Name;
Fmode : Mode)
return File_Descriptor;
function Create_New_File
(Name : C_File_Name;
Fmode : Mode)
return File_Descriptor;
procedure Delete_File (Name : C_File_Name; Success : out Boolean);
procedure Rename_File
(Old_Name : C_File_Name;
New_Name : C_File_Name;
Success : out Boolean);
function File_Time_Stamp (Name : C_File_Name) return OS_Time;
function Is_Regular_File (Name : C_File_Name) return Boolean;
function Is_Directory (Name : C_File_Name) return Boolean;
function Is_Writable_File (Name : C_File_Name) return Boolean;
function Locate_Regular_File
(File_Name : C_File_Name;
Path : C_File_Name)
return String_Access;
------------------
-- Subprocesses --
------------------
type Argument_List is array (Positive range <>) of String_Access;
-- Type used for argument list in call to Spawn. The lower bound
-- of the array should be 1, and the length of the array indicates
-- the number of arguments.
type Argument_List_Access is access all Argument_List;
-- Type used to return an Argument_List without dragging in secondary
-- stack.
procedure Spawn
(Program_Name : String;
Args : Argument_List;
Success : out Boolean);
-- The first parameter of function Spawn is the name of the executable.
-- The second parameter contains the arguments to be passed to the
-- program. Success is False if the named program could not be spawned
-- or its execution completed unsuccessfully. Note that the caller will
-- be blocked until the execution of the spawned program is complete.
-- For maximum portability, use a full path name for the Program_Name
-- argument. On some systems (notably Unix systems) a simple file
-- name may also work (if the executable can be located in the path).
--
-- Note: Arguments that contain spaces and/or quotes such as
-- "--GCC=gcc -v" or "--GCC=""gcc-v""" are not portable
-- across OSes. They may or may not have the desired effect.
function Spawn
(Program_Name : String;
Args : Argument_List)
return Integer;
-- Like above, but as function returning the exact exit status
type Process_Id is private;
-- A private type used to identify a process activated by the following
-- non-blocking call. The only meaningful operation on this type is a
-- comparison for equality.
Invalid_Pid : constant Process_Id;
-- A special value used to indicate errors, as described below.
function Non_Blocking_Spawn
(Program_Name : String;
Args : Argument_List)
return Process_Id;
-- This is a non blocking call. The Process_Id of the spawned process
-- is returned. Parameters are to be used as in Spawn. If Invalid_Id
-- is returned the program could not be spawned.
procedure Wait_Process (Pid : out Process_Id; Success : out Boolean);
-- Wait for the completion of any of the processes created by previous
-- calls to Non_Blocking_Spawn. The caller will be suspended until one
-- of these processes terminates (normally or abnormally). If any of
-- these subprocesses terminates prior to the call to Wait_Process (and
-- has not been returned by a previous call to Wait_Process), then the
-- call to Wait_Process is immediate. Pid identifies the process that
-- has terminated (matching the value returned from Non_Blocking_Spawn).
-- Success is set to True if this sub-process terminated successfully.
-- If Pid = Invalid_Id, there were no subprocesses left to wait on.
function Argument_String_To_List
(Arg_String : String)
return Argument_List_Access;
-- Take a string that is a program and it's arguments and parse it into
-- an Argument_List.
-------------------
-- Miscellaneous --
-------------------
function Getenv (Name : String) return String_Access;
-- Get the value of the environment variable. Returns an access
-- to the empty string if the environment variable does not exist
-- or has an explicit null value (in some operating systems these
-- are distinct cases, in others they are not; this interface
-- abstracts away that difference.
procedure Setenv (Name : String; Value : String);
-- Set the value of the environment variable Name to Value. This call
-- modifies the current environment, but does not modify the parent
-- process environment. After a call to Setenv, Getenv (Name) will
-- always return a String_Access referencing the same String as Value.
-- This is true also for the null string case (the actual effect may
-- be to either set an explicit null as the value, or to remove the
-- entry, this is operating system dependent). Note that any following
-- calls to Spawn will pass an environment to the spawned process that
-- includes the changes made by Setenv calls. This procedure is not
-- available under VMS.
procedure OS_Exit (Status : Integer);
pragma Import (C, OS_Exit, "__gnat_os_exit");
-- Exit to OS with given status code (program is terminated)
procedure OS_Abort;
pragma Import (C, OS_Abort, "abort");
-- Exit to OS signalling an abort (traceback or other appropriate
-- diagnostic information should be given if possible, or entry made
-- to the debugger if that is possible).
function Errno return Integer;
pragma Import (C, Errno, "__get_errno");
-- Return the task-safe last error number.
procedure Set_Errno (Errno : Integer);
pragma Import (C, Set_Errno, "__set_errno");
-- Set the task-safe error number.
Directory_Separator : constant Character;
-- The character that is used to separate parts of a pathname.
Path_Separator : constant Character;
-- The character to separate paths in an environment variable value.
private
pragma Import (C, Path_Separator, "__gnat_path_separator");
pragma Import (C, Directory_Separator, "__gnat_dir_separator");
type OS_Time is new Integer;
type File_Descriptor is new Integer;
Standin : constant File_Descriptor := 0;
Standout : constant File_Descriptor := 1;
Standerr : constant File_Descriptor := 2;
Invalid_FD : constant File_Descriptor := -1;
type Process_Id is new Integer;
Invalid_Pid : constant Process_Id := -1;
end GNAT.OS_Lib;

1477
gcc/ada/g-regexp.adb Normal file
View File

File diff suppressed because it is too large Load Diff

163
gcc/ada/g-regexp.ads Normal file
View File

@ -0,0 +1,163 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E G E X P --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Simple Regular expression matching
-- This package provides a simple implementation of a regular expression
-- pattern matching algorithm, using a subset of the syntax of regular
-- expressions copied from familiar Unix style utilities.
------------------------------------------------------------
-- Summary of Pattern Matching Packages in GNAT Hierarchy --
------------------------------------------------------------
-- There are three related packages that perform pattern maching functions.
-- the following is an outline of these packages, to help you determine
-- which is best for your needs.
-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb)
-- This is a simple package providing Unix-style regular expression
-- matching with the restriction that it matches entire strings. It
-- is particularly useful for file name matching, and in particular
-- it provides "globbing patterns" that are useful in implementing
-- unix or DOS style wild card matching for file names.
-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb)
-- This is a more complete implementation of Unix-style regular
-- expressions, copied from the original V7 style regular expression
-- library written in C by Henry Spencer. It is functionally the
-- same as this library, and uses the same internal data structures
-- stored in a binary compatible manner.
-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb)
-- This is a completely general patterm matching package based on the
-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern
-- language is modeled on context free grammars, with context sensitive
-- extensions that provide full (type 0) computational capabilities.
with Ada.Finalization;
package GNAT.Regexp is
-- The regular expression must first be compiled, using the Compile
-- function, which creates a finite state matching table, allowing
-- very fast matching once the expression has been compiled.
-- The following is the form of a regular expression, expressed in Ada
-- reference manual style BNF is as follows
-- regexp ::= term
-- regexp ::= term | term -- alternation (term or term ...)
-- term ::= item
-- term ::= item item ... -- concatenation (item then item)
-- item ::= elmt -- match elmt
-- item ::= elmt * -- zero or more elmt's
-- item ::= elmt + -- one or more elmt's
-- item ::= elmt ? -- matches elmt or nothing
-- elmt ::= nchr -- matches given character
-- elmt ::= [nchr nchr ...] -- matches any character listed
-- elmt ::= [^ nchr nchr ...] -- matches any character not listed
-- elmt ::= [char - char] -- matches chars in given range
-- elmt ::= . -- matches any single character
-- elmt ::= ( regexp ) -- parens used for grouping
-- char ::= any character, including special characters
-- nchr ::= any character except \()[].*+?^ or \char to match char
-- ... is used to indication repetition (one or more terms)
-- See also regexp(1) man page on Unix systems for further details
-- A second kind of regular expressions is provided. This one is more
-- like the wild card patterns used in file names by the Unix shell (or
-- DOS prompt) command lines. The grammar is the following:
-- regexp ::= term
-- term ::= elmt
-- term ::= elmt elmt ... -- concatenation (elmt then elmt)
-- term ::= * -- any string of 0 or more characters
-- term ::= ? -- matches any character
-- term ::= [char char ...] -- matches any character listed
-- term ::= [char - char] -- matches any character in given range
-- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt)
-- Important note : This package was mainly intended to match regular
-- expressions against file names. The whole string has to match the
-- regular expression. If only a substring matches, then the function
-- Match will return False.
type Regexp is private;
-- Private type used to represent a regular expression
Error_In_Regexp : exception;
-- Exception raised when an error is found in the regular expression
function Compile
(Pattern : String;
Glob : Boolean := False;
Case_Sensitive : Boolean := True)
return Regexp;
-- Compiles a regular expression S. If the syntax of the given
-- expression is invalid (does not match above grammar, Error_In_Regexp
-- is raised. If Glob is True, the pattern is considered as a 'globbing
-- pattern', that is a pattern as given by the second grammar above
function Match (S : String; R : Regexp) return Boolean;
-- True if S matches R, otherwise False. Raises Constraint_Error if
-- R is an uninitialized regular expression value.
private
type Regexp_Value;
type Regexp_Access is access Regexp_Value;
type Regexp is new Ada.Finalization.Controlled with record
R : Regexp_Access := null;
end record;
pragma Finalize_Storage_Only (Regexp);
procedure Finalize (R : in out Regexp);
-- Free the memory occupied by R
procedure Adjust (R : in out Regexp);
-- Called after an assignment (do a copy of the Regexp_Access.all)
end GNAT.Regexp;

434
gcc/ada/g-regist.adb Normal file
View File

@ -0,0 +1,434 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E G I S T R Y --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Interfaces.C;
with System;
package body GNAT.Registry is
use Ada;
use System;
------------------------------
-- Binding to the Win32 API --
------------------------------
subtype LONG is Interfaces.C.long;
subtype ULONG is Interfaces.C.unsigned_long;
subtype DWORD is ULONG;
type PULONG is access all ULONG;
subtype PDWORD is PULONG;
subtype LPDWORD is PDWORD;
subtype Error_Code is LONG;
subtype REGSAM is LONG;
type PHKEY is access all HKEY;
ERROR_SUCCESS : constant Error_Code := 0;
REG_SZ : constant := 1;
function RegCloseKey (Key : HKEY) return LONG;
pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
function RegCreateKeyEx
(Key : HKEY;
lpSubKey : Address;
Reserved : DWORD;
lpClass : Address;
dwOptions : DWORD;
samDesired : REGSAM;
lpSecurityAttributes : Address;
phkResult : PHKEY;
lpdwDisposition : LPDWORD)
return LONG;
pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
function RegDeleteKey
(Key : HKEY;
lpSubKey : Address)
return LONG;
pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
function RegDeleteValue
(Key : HKEY;
lpValueName : Address)
return LONG;
pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
function RegEnumValue
(Key : HKEY;
dwIndex : DWORD;
lpValueName : Address;
lpcbValueName : LPDWORD;
lpReserved : LPDWORD;
lpType : LPDWORD;
lpData : Address;
lpcbData : LPDWORD)
return LONG;
pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
function RegOpenKeyEx
(Key : HKEY;
lpSubKey : Address;
ulOptions : DWORD;
samDesired : REGSAM;
phkResult : PHKEY)
return LONG;
pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
function RegQueryValueEx
(Key : HKEY;
lpValueName : Address;
lpReserved : LPDWORD;
lpType : LPDWORD;
lpData : Address;
lpcbData : LPDWORD)
return LONG;
pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
function RegSetValueEx
(Key : HKEY;
lpValueName : Address;
Reserved : DWORD;
dwType : DWORD;
lpData : Address;
cbData : DWORD)
return LONG;
pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
-----------------------
-- Local Subprograms --
-----------------------
function To_C_Mode (Mode : Key_Mode) return REGSAM;
-- Returns the Win32 mode value for the Key_Mode value.
procedure Check_Result (Result : LONG; Message : String);
-- Checks value Result and raise the exception Registry_Error if it is not
-- equal to ERROR_SUCCESS. Message and the error value (Result) is added
-- to the exception message.
------------------
-- Check_Result --
------------------
procedure Check_Result (Result : LONG; Message : String) is
use type LONG;
begin
if Result /= ERROR_SUCCESS then
Exceptions.Raise_Exception
(Registry_Error'Identity,
Message & " (" & LONG'Image (Result) & ')');
end if;
end Check_Result;
---------------
-- Close_Key --
---------------
procedure Close_Key (Key : HKEY) is
Result : LONG;
begin
Result := RegCloseKey (Key);
Check_Result (Result, "Close_Key");
end Close_Key;
----------------
-- Create_Key --
----------------
function Create_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Write)
return HKEY
is
use type REGSAM;
use type DWORD;
REG_OPTION_NON_VOLATILE : constant := 16#0#;
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
C_Class : constant String := "" & ASCII.Nul;
C_Mode : constant REGSAM := To_C_Mode (Mode);
New_Key : aliased HKEY;
Result : LONG;
Dispos : aliased DWORD;
begin
Result := RegCreateKeyEx
(From_Key,
C_Sub_Key (C_Sub_Key'First)'Address,
0,
C_Class (C_Class'First)'Address,
REG_OPTION_NON_VOLATILE,
C_Mode,
Null_Address,
New_Key'Unchecked_Access,
Dispos'Unchecked_Access);
Check_Result (Result, "Create_Key " & Sub_Key);
return New_Key;
end Create_Key;
----------------
-- Delete_Key --
----------------
procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
Result : LONG;
begin
Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
Check_Result (Result, "Delete_Key " & Sub_Key);
end Delete_Key;
------------------
-- Delete_Value --
------------------
procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
Result : LONG;
begin
Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
Check_Result (Result, "Delete_Value " & Sub_Key);
end Delete_Value;
-------------------------
-- For_Every_Key_Value --
-------------------------
procedure For_Every_Key_Value (From_Key : HKEY) is
use type LONG;
use type ULONG;
Index : ULONG := 0;
Result : LONG;
Sub_Key : String (1 .. 100);
pragma Warnings (Off, Sub_Key);
Value : String (1 .. 100);
pragma Warnings (Off, Value);
Size_Sub_Key : aliased ULONG;
Size_Value : aliased ULONG;
Type_Sub_Key : aliased DWORD;
Quit : Boolean;
begin
loop
Size_Sub_Key := Sub_Key'Length;
Size_Value := Value'Length;
Result := RegEnumValue
(From_Key, Index,
Sub_Key (1)'Address,
Size_Sub_Key'Unchecked_Access,
null,
Type_Sub_Key'Unchecked_Access,
Value (1)'Address,
Size_Value'Unchecked_Access);
exit when not (Result = ERROR_SUCCESS);
if Type_Sub_Key = REG_SZ then
Quit := False;
Action (Natural (Index) + 1,
Sub_Key (1 .. Integer (Size_Sub_Key)),
Value (1 .. Integer (Size_Value) - 1),
Quit);
exit when Quit;
Index := Index + 1;
end if;
end loop;
end For_Every_Key_Value;
----------------
-- Key_Exists --
----------------
function Key_Exists
(From_Key : HKEY;
Sub_Key : String)
return Boolean
is
New_Key : HKEY;
begin
New_Key := Open_Key (From_Key, Sub_Key);
Close_Key (New_Key);
-- We have been able to open the key so it exists
return True;
exception
when Registry_Error =>
-- An error occured, the key was not found
return False;
end Key_Exists;
--------------
-- Open_Key --
--------------
function Open_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Only)
return HKEY
is
use type REGSAM;
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
C_Mode : constant REGSAM := To_C_Mode (Mode);
New_Key : aliased HKEY;
Result : LONG;
begin
Result := RegOpenKeyEx
(From_Key,
C_Sub_Key (C_Sub_Key'First)'Address,
0,
C_Mode,
New_Key'Unchecked_Access);
Check_Result (Result, "Open_Key " & Sub_Key);
return New_Key;
end Open_Key;
-----------------
-- Query_Value --
-----------------
function Query_Value
(From_Key : HKEY;
Sub_Key : String)
return String
is
use type LONG;
use type ULONG;
Value : String (1 .. 100);
pragma Warnings (Off, Value);
Size_Value : aliased ULONG;
Type_Value : aliased DWORD;
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
Result : LONG;
begin
Size_Value := Value'Length;
Result := RegQueryValueEx
(From_Key,
C_Sub_Key (C_Sub_Key'First)'Address,
null,
Type_Value'Unchecked_Access,
Value (Value'First)'Address,
Size_Value'Unchecked_Access);
Check_Result (Result, "Query_Value " & Sub_Key & " key");
return Value (1 .. Integer (Size_Value - 1));
end Query_Value;
---------------
-- Set_Value --
---------------
procedure Set_Value
(From_Key : HKEY;
Sub_Key : String;
Value : String)
is
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
C_Value : constant String := Value & ASCII.Nul;
Result : LONG;
begin
Result := RegSetValueEx
(From_Key,
C_Sub_Key (C_Sub_Key'First)'Address,
0,
REG_SZ,
C_Value (C_Value'First)'Address,
C_Value'Length);
Check_Result (Result, "Set_Value " & Sub_Key & " key");
end Set_Value;
---------------
-- To_C_Mode --
---------------
function To_C_Mode (Mode : Key_Mode) return REGSAM is
use type REGSAM;
KEY_READ : constant := 16#20019#;
KEY_WRITE : constant := 16#20006#;
begin
case Mode is
when Read_Only =>
return KEY_READ;
when Read_Write =>
return KEY_READ + KEY_WRITE;
end case;
end To_C_Mode;
end GNAT.Registry;

133
gcc/ada/g-regist.ads Normal file
View File

@ -0,0 +1,133 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E G I S T R Y --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- The registry is a Windows database to store key/value pair. It is used
-- to keep Windows operation system and applications configuration options.
-- The database is a hierarchal set of key and for each key a value can
-- be associated. This package provides high level routines to deal with
-- the Windows registry. For full registry API, but at a lower level of
-- abstraction, refer to the Win32.Winreg package provided with the
-- Win32Ada binding. For example this binding handle only key values of
-- type Standard.String.
-- This package is specific to the NT version of GNAT, and is not available
-- on any other platforms.
package GNAT.Registry is
type HKEY is private;
-- HKEY is a handle to a registry key, including standard registry keys:
-- HKEY_CLASSES_ROOT, HKEY_CURRENT_CONFIG, HKEY_CURRENT_USER,
-- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA.
HKEY_CLASSES_ROOT : constant HKEY;
HKEY_CURRENT_USER : constant HKEY;
HKEY_CURRENT_CONFIG : constant HKEY;
HKEY_LOCAL_MACHINE : constant HKEY;
HKEY_USERS : constant HKEY;
HKEY_PERFORMANCE_DATA : constant HKEY;
type Key_Mode is (Read_Only, Read_Write);
-- Access mode for the registry key.
Registry_Error : exception;
-- Registry_Error is raises by all routines below if a problem occurs
-- (key cannot be opened, key cannot be found etc).
function Create_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Write)
return HKEY;
-- Open or create a key (named Sub_Key) in the Windows registry database.
-- The key will be created under key From_Key. It returns the key handle.
-- From_Key must be a valid handle to an already opened key or one of
-- the standard keys identified by HKEY declarations above.
function Open_Key
(From_Key : HKEY;
Sub_Key : String;
Mode : Key_Mode := Read_Only)
return HKEY;
-- Return a registry key handle for key named Sub_Key opened under key
-- From_Key. It is possible to open a key at any level in the registry
-- tree in a single call to Open_Key.
procedure Close_Key (Key : HKEY);
-- Close registry key handle. All resources used by Key are released.
function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean;
-- Returns True if Sub_Key is defined under From_Key in the registry.
function Query_Value (From_Key : HKEY; Sub_Key : String) return String;
-- Returns the registry key's value associated with Sub_Key in From_Key
-- registry key.
procedure Set_Value (From_Key : HKEY; Sub_Key : String; Value : String);
-- Add the pair (Sub_Key, Value) into From_Key registry key.
procedure Delete_Key (From_Key : HKEY; Sub_Key : String);
-- Remove Sub_Key from the registry key From_Key.
procedure Delete_Value (From_Key : HKEY; Sub_Key : String);
-- Remove the named value Sub_Key from the registry key From_Key.
generic
with procedure Action
(Index : Positive;
Sub_Key : String;
Value : String;
Quit : in out Boolean);
procedure For_Every_Key_Value (From_Key : HKEY);
-- Iterates over all the pairs (Sub_Key, Value) registered under
-- From_Key. Index will be set to 1 for the first key and will be
-- incremented by one in each iteration. Quit can be set to True to
-- stop iteration; its initial value is False.
--
-- Key value that are not of type string are skipped. In this case, the
-- iterator behaves exactly as if the key was not present. Note that you
-- must use the Win32.Winreg API to deal with this case.
private
type HKEY is mod 2 ** Integer'Size;
HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#;
HKEY_CURRENT_USER : constant HKEY := 16#80000001#;
HKEY_LOCAL_MACHINE : constant HKEY := 16#80000002#;
HKEY_USERS : constant HKEY := 16#80000003#;
HKEY_PERFORMANCE_DATA : constant HKEY := 16#80000004#;
HKEY_CURRENT_CONFIG : constant HKEY := 16#80000005#;
end GNAT.Registry;

3545
gcc/ada/g-regpat.adb Normal file
View File

File diff suppressed because it is too large Load Diff

548
gcc/ada/g-regpat.ads Normal file
View File

@ -0,0 +1,548 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . R E G P A T --
-- --
-- S p e c --
-- --
-- $Revision: 1.27 $
-- --
-- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1996-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package implements roughly the same set of regular expressions as
-- are available in the Perl or Python programming languages.
-- This is an extension of the original V7 style regular expression library
-- written in C by Henry Spencer. Apart from the translation to Ada, the
-- interface has been considerably changed to use the Ada String type
-- instead of C-style nul-terminated strings.
------------------------------------------------------------
-- Summary of Pattern Matching Packages in GNAT Hierarchy --
------------------------------------------------------------
-- There are three related packages that perform pattern maching functions.
-- the following is an outline of these packages, to help you determine
-- which is best for your needs.
-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb)
-- This is a simple package providing Unix-style regular expression
-- matching with the restriction that it matches entire strings. It
-- is particularly useful for file name matching, and in particular
-- it provides "globbing patterns" that are useful in implementing
-- unix or DOS style wild card matching for file names.
-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb)
-- This is a more complete implementation of Unix-style regular
-- expressions, copied from the Perl regular expression engine,
-- written originally in C by Henry Spencer. It is functionally the
-- same as that library.
-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb)
-- This is a completely general pattern matching package based on the
-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern
-- language is modeled on context free grammars, with context sensitive
-- extensions that provide full (type 0) computational capabilities.
package GNAT.Regpat is
pragma Preelaborate (Regpat);
-- The grammar is the following:
-- regexp ::= expr
-- ::= ^ expr -- anchor at the beginning of string
-- ::= expr $ -- anchor at the end of string
-- expr ::= term
-- ::= term | term -- alternation (term or term ...)
-- term ::= item
-- ::= item item ... -- concatenation (item then item)
-- item ::= elmt -- match elmt
-- ::= elmt * -- zero or more elmt's
-- ::= elmt + -- one or more elmt's
-- ::= elmt ? -- matches elmt or nothing
-- ::= elmt *? -- zero or more times, minimum number
-- ::= elmt +? -- one or more times, minimum number
-- ::= elmt ?? -- zero or one time, minimum number
-- ::= elmt { num } -- matches elmt exactly num times
-- ::= elmt { num , } -- matches elmt at least num times
-- ::= elmt { num , num2 } -- matches between num and num2 times
-- ::= elmt { num }? -- matches elmt exactly num times
-- ::= elmt { num , }? -- matches elmt at least num times
-- non-greedy version
-- ::= elmt { num , num2 }? -- matches between num and num2 times
-- non-greedy version
-- elmt ::= nchr -- matches given character
-- ::= [range range ...] -- matches any character listed
-- ::= [^ range range ...] -- matches any character not listed
-- ::= . -- matches any single character
-- -- except newlines
-- ::= ( expr ) -- parens used for grouping
-- ::= \ num -- reference to num-th parenthesis
-- range ::= char - char -- matches chars in given range
-- ::= nchr
-- ::= [: posix :] -- any character in the POSIX range
-- ::= [:^ posix :] -- not in the POSIX range
-- posix ::= alnum -- alphanumeric characters
-- ::= alpha -- alphabetic characters
-- ::= ascii -- ascii characters (0 .. 127)
-- ::= cntrl -- control chars (0..31, 127..159)
-- ::= digit -- digits ('0' .. '9')
-- ::= graph -- graphic chars (32..126, 160..255)
-- ::= lower -- lower case characters
-- ::= print -- printable characters (32..127)
-- ::= punct -- printable, except alphanumeric
-- ::= space -- space characters
-- ::= upper -- upper case characters
-- ::= word -- alphanumeric characters
-- ::= xdigit -- hexadecimal chars (0..9, a..f)
-- char ::= any character, including special characters
-- ASCII.NUL is not supported.
-- nchr ::= any character except \()[].*+?^ or \char to match char
-- \n means a newline (ASCII.LF)
-- \t means a tab (ASCII.HT)
-- \r means a return (ASCII.CR)
-- \b matches the empty string at the beginning or end of a
-- word. A word is defined as a set of alphanumerical
-- characters (see \w below).
-- \B matches the empty string only when *not* at the
-- beginning or end of a word.
-- \d matches any digit character ([0-9])
-- \D matches any non digit character ([^0-9])
-- \s matches any white space character. This is equivalent
-- to [ \t\n\r\f\v] (tab, form-feed, vertical-tab,...
-- \S matches any non-white space character.
-- \w matches any alphanumeric character or underscore.
-- This include accented letters, as defined in the
-- package Ada.Characters.Handling.
-- \W matches any non-alphanumeric character.
-- \A match the empty string only at the beginning of the
-- string, whatever flags are used for Compile (the
-- behavior of ^ can change, see Regexp_Flags below).
-- \G match the empty string only at the end of the
-- string, whatever flags are used for Compile (the
-- behavior of $ can change, see Regexp_Flags below).
-- ... ::= is used to indication repetition (one or more terms)
-- Embedded newlines are not matched by the ^ operator.
-- It is possible to retrieve the substring matched a parenthesis
-- expression. Although the depth of parenthesis is not limited in the
-- regexp, only the first 9 substrings can be retrieved.
-- The highest value possible for the arguments to the curly operator ({})
-- are given by the constant Max_Curly_Repeat below.
-- The operators '*', '+', '?' and '{}' always match the longest possible
-- substring. They all have a non-greedy version (with an extra ? after the
-- operator), which matches the shortest possible substring.
-- For instance:
-- regexp="<.*>" string="<h1>title</h1>" matches="<h1>title</h1>"
-- regexp="<.*?>" string="<h1>title</h1>" matches="<h1>"
--
-- '{' and '}' are only considered as special characters if they appear
-- in a substring that looks exactly like '{n}', '{n,m}' or '{n,}', where
-- n and m are digits. No space is allowed. In other contexts, the curly
-- braces will simply be treated as normal characters.
-- Compiling Regular Expressions
-- =============================
-- To use this package, you first need to compile the regular expression
-- (a string) into a byte-code program, in a Pattern_Matcher structure.
-- This first step checks that the regexp is valid, and optimizes the
-- matching algorithms of the second step.
-- Two versions of the Compile subprogram are given: one in which this
-- package will compute itself the best possible size to allocate for the
-- byte code; the other where you must allocate enough memory yourself. An
-- exception is raised if there is not enough memory.
-- declare
-- Regexp : String := "a|b";
-- Matcher : Pattern_Matcher := Compile (Regexp);
-- -- The size for matcher is automatically allocated
-- Matcher2 : Pattern_Matcher (1000);
-- -- Some space is allocated directly.
-- begin
-- Compile (Matcher2, Regexp);
-- ...
-- end;
-- Note that the second version is significantly faster, since with the
-- first version the regular expression has in fact to be compiled twice
-- (first to compute the size, then to generate the byte code).
-- Note also that you can not use the function version of Compile if you
-- specify the size of the Pattern_Matcher, since the discriminants will
-- most probably be different and you will get a Constraint_Error
-- Matching Strings
-- ================
-- Once the regular expression has been compiled, you can use it as often
-- as needed to match strings.
-- Several versions of the Match subprogram are provided, with different
-- parameters and return results.
-- See the description under each of these subprograms.
-- Here is a short example showing how to get the substring matched by
-- the first parenthesis pair.
-- declare
-- Matches : Match_Array;
-- Regexp : String := "a(b|c)d";
-- Str : String := "gacdg";
-- begin
-- Match (Compile (Regexp), Str, Matches);
-- return Str (Matches (1).First .. Matches (1).Last);
-- -- returns 'c'
-- end;
-- String Substitution
-- ===================
-- No subprogram is currently provided for string substitution.
-- However, this is easy to simulate with the parenthesis groups, as
-- shown below.
-- This example swaps the first two words of the string:
-- declare
-- Regexp : String := "([a-z]+) +([a-z]+)";
-- Str : String := " first second third ";
-- Matches : Match_Array;
-- begin
-- Match (Compile (Regexp), Str, Matches);
-- return Str (Str'First .. Matches (1).First - 1)
-- & Str (Matches (2).First .. Matches (2).Last)
-- & " "
-- & Str (Matches (1).First .. Matches (1).Last)
-- & Str (Matches (2).Last + 1 .. Str'Last);
-- -- returns " second first third "
-- end;
---------------
-- Constants --
---------------
Expression_Error : exception;
-- This exception is raised when trying to compile an invalid
-- regular expression. All subprograms taking an expression
-- as parameter may raise Expression_Error.
Max_Paren_Count : constant := 255;
-- Maximum number of parenthesis in a regular expression.
-- This is limited by the size of a Character, as found in the
-- byte-compiled version of regular expressions.
Max_Program_Size : constant := 2**15 - 1;
-- Maximum size that can be allocated for a program.
Max_Curly_Repeat : constant := 32767;
-- Maximum number of repetition for the curly operator.
-- The digits in the {n}, {n,} and {n,m } operators can not be higher
-- than this constant, since they have to fit on two characters in the
-- byte-compiled version of regular expressions.
type Program_Size is range 0 .. Max_Program_Size;
for Program_Size'Size use 16;
-- Number of bytes allocated for the byte-compiled version of a regular
-- expression.
type Regexp_Flags is mod 256;
for Regexp_Flags'Size use 8;
-- Flags that can be given at compile time to specify default
-- properties for the regular expression.
No_Flags : constant Regexp_Flags;
Case_Insensitive : constant Regexp_Flags;
-- The automaton is optimized so that the matching is done in a case
-- insensitive manner (upper case characters and lower case characters
-- are all treated the same way).
Single_Line : constant Regexp_Flags;
-- Treat the Data we are matching as a single line. This means that
-- ^ and $ will ignore \n (unless Multiple_Lines is also specified),
-- and that '.' will match \n.
Multiple_Lines : constant Regexp_Flags;
-- Treat the Data as multiple lines. This means that ^ and $ will also
-- match on internal newlines (ASCII.LF), in addition to the beginning
-- and end of the string.
--
-- This can be combined with Single_Line.
-----------------
-- Match_Array --
-----------------
subtype Match_Count is Natural range 0 .. Max_Paren_Count;
type Match_Location is record
First : Natural := 0;
Last : Natural := 0;
end record;
type Match_Array is array (Match_Count range <>) of Match_Location;
-- The substring matching a given pair of parenthesis.
-- Index 0 is the whole substring that matched the full regular
-- expression.
--
-- For instance, if your regular expression is something like:
-- "a(b*)(c+)", then Match_Array(1) will be the indexes of the
-- substring that matched "b*" and Match_Array(2) will be the substring
-- that matched "c+".
--
-- The number of parenthesis groups that can be retrieved is unlimited,
-- and all the Match subprograms below can use a Match_Array of any size.
-- Indexes that do not have any matching parenthesis are set to
-- No_Match.
No_Match : constant Match_Location := (First => 0, Last => 0);
-- The No_Match constant is (0, 0) to differentiate between
-- matching a null string at position 1, which uses (1, 0)
-- and no match at all.
------------------------------
-- Pattern_Matcher Creation --
------------------------------
type Pattern_Matcher (Size : Program_Size) is private;
-- Type used to represent a regular expression compiled into byte code
Never_Match : constant Pattern_Matcher;
-- A regular expression that never matches anything
function Compile
(Expression : String;
Flags : Regexp_Flags := No_Flags)
return Pattern_Matcher;
-- Compile a regular expression into internal code.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The appropriate size is calculated automatically, but this means that
-- the regular expression has to be compiled twice (the first time to
-- calculate the size, the second time to actually generate the byte code).
--
-- Flags is the default value to use to set properties for Expression (case
-- sensitivity,...).
procedure Compile
(Matcher : out Pattern_Matcher;
Expression : String;
Final_Code_Size : out Program_Size;
Flags : Regexp_Flags := No_Flags);
-- Compile a regular expression into into internal code
-- This procedure is significantly faster than the function
-- Compile, as there is a known maximum size for the matcher.
-- This function raises Storage_Error if Matcher is too small
-- to hold the resulting code, or Expression_Error is Expression
-- is not a legal regular expression.
--
-- Flags is the default value to use to set properties for Expression (case
-- sensitivity,...).
procedure Compile
(Matcher : out Pattern_Matcher;
Expression : String;
Flags : Regexp_Flags := No_Flags);
-- Same procedure as above, expect it does not return the final
-- program size.
function Paren_Count (Regexp : Pattern_Matcher) return Match_Count;
pragma Inline (Paren_Count);
-- Return the number of parenthesis pairs in Regexp.
-- This is the maximum index that will be filled if a Match_Array is
-- used as an argument to Match.
--
-- Thus, if you want to be sure to get all the parenthesis, you should
-- do something like:
--
-- declare
-- Regexp : Pattern_Matcher := Compile ("a(b*)(c+)");
-- Matched : Match_Array (0 .. Paren_Count (Regexp));
-- begin
-- Match (Regexp, "a string", Matched);
-- end;
-------------
-- Quoting --
-------------
function Quote (Str : String) return String;
-- Return a version of Str so that every special character is quoted.
-- The resulting string can be used in a regular expression to match
-- exactly Str, whatever character was present in Str.
--------------
-- Matching --
--------------
procedure Match
(Expression : String;
Data : String;
Matches : out Match_Array;
Size : Program_Size := 0);
-- Match Expression against Data and store result in Matches.
-- Function raises Storage_Error if Size is too small for Expression,
-- or Expression_Error if Expression is not a legal regular expression.
-- If Size is 0, then the appropriate size is automatically calculated
-- by this package, but this is slightly slower.
--
-- At most Matches'Length parenthesis are returned.
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0)
return Natural;
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match.
-- Function raises Storage_Error if Size is too small for Expression
-- or Expression_Error if Expression is not a legal regular expression
-- If Size is 0, then the appropriate size is automatically calculated
-- by this package, but this is slightly slower.
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0)
return Boolean;
-- Return True if Data matches Expression. Match raises Storage_Error
-- if Size is too small for Expression, or Expression_Error if Expression
-- is not a legal regular expression.
--
-- If Size is 0, then the appropriate size is automatically calculated
-- by this package, but this is slightly slower.
------------------------------------------------
-- Matching a pre-compiled regular expression --
------------------------------------------------
-- The following functions are significantly faster if you need to reuse
-- the same regular expression multiple times, since you only have to
-- compile it once.
function Match
(Self : Pattern_Matcher;
Data : String)
return Natural;
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match. Raises Expression_Error if Expression is not a legal regular
-- expression.
pragma Inline (Match);
-- All except the last one below.
procedure Match
(Self : Pattern_Matcher;
Data : String;
Matches : out Match_Array);
-- Match Data using the given pattern matcher and store result in Matches.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The expression matches if Matches (0) /= No_Match.
--
-- At most Matches'Length parenthesis are returned.
-----------
-- Debug --
-----------
procedure Dump (Self : Pattern_Matcher);
-- Dump the compiled version of the regular expression matched by Self.
--------------------------
-- Private Declarations --
--------------------------
private
subtype Pointer is Program_Size;
-- The Pointer type is used to point into Program_Data
-- Note that the pointer type is not necessarily 2 bytes
-- although it is stored in the program using 2 bytes
type Program_Data is array (Pointer range <>) of Character;
Program_First : constant := 1;
-- The "internal use only" fields in regexp are present to pass
-- info from compile to execute that permits the execute phase
-- to run lots faster on simple cases. They are:
-- First character that must begin a match or ASCII.Nul
-- Anchored true iff match must start at beginning of line
-- Must_Have pointer to string that match must include or null
-- Must_Have_Length length of Must_Have string
-- First and Anchored permit very fast decisions on suitable
-- starting points for a match, cutting down the work a lot.
-- Must_Have permits fast rejection of lines that cannot possibly
-- match.
-- The Must_Have tests are costly enough that Optimize
-- supplies a Must_Have only if the r.e. contains something potentially
-- expensive (at present, the only such thing detected is * or +
-- at the start of the r.e., which can involve a lot of backup).
-- The length is supplied because the test in Execute needs it
-- and Optimize is computing it anyway.
-- The initialization is meant to fail-safe in case the user of this
-- package tries to use an uninitialized matcher. This takes advantage
-- of the knowledge that ASCII.Nul translates to the end-of-program (EOP)
-- instruction code of the state machine.
No_Flags : constant Regexp_Flags := 0;
Case_Insensitive : constant Regexp_Flags := 1;
Single_Line : constant Regexp_Flags := 2;
Multiple_Lines : constant Regexp_Flags := 4;
type Pattern_Matcher (Size : Pointer) is record
First : Character := ASCII.NUL; -- internal use only
Anchored : Boolean := False; -- internal use only
Must_Have : Pointer := 0; -- internal use only
Must_Have_Length : Natural := 0; -- internal use only
Paren_Count : Natural := 0; -- # paren groups
Flags : Regexp_Flags := No_Flags;
Program : Program_Data (Program_First .. Size) :=
(others => ASCII.NUL);
end record;
Never_Match : constant Pattern_Matcher :=
(0, ASCII.NUL, False, 0, 0, 0, No_Flags, (others => ASCII.NUL));
end GNAT.Regpat;

115
gcc/ada/g-soccon.ads Normal file
View File

@ -0,0 +1,115 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . C O N S T A N T S --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is the version for Linux
package GNAT.Sockets.Constants is
-- Families
AF_INET : constant := 2;
AF_INET6 : constant := 10;
-- Modes
SOCK_STREAM : constant := 1;
SOCK_DGRAM : constant := 2;
-- Socket Errors
EBADF : constant := 9;
ENOTSOCK : constant := 88;
ENOTCONN : constant := 107;
ENOBUFS : constant := 105;
EOPNOTSUPP : constant := 95;
EFAULT : constant := 14;
EWOULDBLOCK : constant := 11;
EADDRNOTAVAIL : constant := 99;
EMSGSIZE : constant := 90;
EADDRINUSE : constant := 98;
EINVAL : constant := 22;
EACCES : constant := 13;
EAFNOSUPPORT : constant := 97;
EISCONN : constant := 106;
ETIMEDOUT : constant := 110;
ECONNREFUSED : constant := 111;
ENETUNREACH : constant := 101;
EALREADY : constant := 114;
EINPROGRESS : constant := 115;
ENOPROTOOPT : constant := 92;
EPROTONOSUPPORT : constant := 93;
EINTR : constant := 4;
EIO : constant := 5;
ESOCKTNOSUPPORT : constant := 94;
-- Host Errors
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
-- Control Flags
FIONBIO : constant := 21537;
FIONREAD : constant := 21531;
-- Shutdown Modes
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
-- Protocol Levels
SOL_SOCKET : constant := 1;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
-- Socket Options
TCP_NODELAY : constant := 1;
SO_SNDBUF : constant := 7;
SO_RCVBUF : constant := 8;
SO_REUSEADDR : constant := 2;
SO_KEEPALIVE : constant := 9;
SO_LINGER : constant := 13;
SO_ERROR : constant := 4;
SO_BROADCAST : constant := 6;
IP_ADD_MEMBERSHIP : constant := 35;
IP_DROP_MEMBERSHIP : constant := 36;
IP_MULTICAST_TTL : constant := 33;
IP_MULTICAST_LOOP : constant := 34;
end GNAT.Sockets.Constants;

1776
gcc/ada/g-socket.adb Normal file
View File

File diff suppressed because it is too large Load Diff

891
gcc/ada/g-socket.ads Normal file
View File

@ -0,0 +1,891 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S --
-- --
-- S p e c --
-- --
-- $Revision: 1.22 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides an interface to the sockets communication facility
-- provided on many operating systems. Currently this is implemented on all
-- native GNAT ports except for VMS. It is not yet implemented for any of
-- the cross-ports (e.g. it is not available for VxWorks or LynxOS).
-- Another restriction is that there is no multicast support under Windows
-- or under any system on which the multicast support is not available or
-- installed.
with Ada.Exceptions;
with Ada.Streams;
package GNAT.Sockets is
-- Sockets are designed to provide a consistent communication
-- facility between applications. This package provides an
-- Ada-like interface similar to the one proposed as part of the
-- BSD socket layer. This is a system independant thick binding.
-- Here is a typical example of what you can do.
-- with GNAT.Sockets; use GNAT.Sockets;
--
-- with Ada.Text_IO;
-- with Ada.Exceptions; use Ada.Exceptions;
--
-- procedure PingPong is
--
-- Group : constant String := "239.255.128.128";
-- -- Multicast groupe: administratively scoped IP address
--
-- task Pong is
-- entry Start;
-- entry Stop;
-- end Pong;
--
-- task body Pong is
-- Address : Sock_Addr_Type;
-- Server : Socket_Type;
-- Socket : Socket_Type;
-- Channel : Stream_Access;
--
-- begin
-- accept Start;
--
-- -- Get an Internet address of a host (here "localhost").
-- -- Note that a host can have several addresses. Here we get
-- -- the first one which is supposed to be the official one.
--
-- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1);
--
-- -- Get a socket address that is an Internet address and a port
--
-- Address.Port := 5432;
--
-- -- The first step is to create a socket. Once created, this
-- -- socket must be associated to with an address. Usually only a
-- -- server (Pong here) needs to bind an address explicitly.
-- -- Most of the time clients can skip this step because the
-- -- socket routines will bind an arbitrary address to an unbound
-- -- socket.
--
-- Create_Socket (Server);
--
-- -- Allow reuse of local addresses.
--
-- Set_Socket_Option
-- (Server,
-- Socket_Level,
-- (Reuse_Address, True));
--
-- Bind_Socket (Server, Address);
--
-- -- A server marks a socket as willing to receive connect events.
--
-- Listen_Socket (Server);
--
-- -- Once a server calls Listen_Socket, incoming connects events
-- -- can be accepted. The returned Socket is a new socket that
-- -- represents the server side of the connection. Server remains
-- -- available to receive further connections.
--
-- Accept_Socket (Server, Socket, Address);
--
-- -- Return a stream associated to the connected socket.
--
-- Channel := Stream (Socket);
--
-- -- Force Pong to block
--
-- delay 0.2;
--
-- -- Receive and print message from client Ping.
--
-- declare
-- Message : String := String'Input (Channel);
--
-- begin
-- Ada.Text_IO.Put_Line (Message);
--
-- -- Send same message to server Pong.
--
-- String'Output (Channel, Message);
-- end;
--
-- Close_Socket (Server);
-- Close_Socket (Socket);
--
-- -- Part of the multicast example
--
-- -- Create a datagram socket to send connectionless, unreliable
-- -- messages of a fixed maximum length.
--
-- Create_Socket (Socket, Family_Inet, Socket_Datagram);
--
-- -- Allow reuse of local addresses.
--
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
--
-- -- Join a multicast group.
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr));
--
-- -- Controls the live time of the datagram to avoid it being
-- -- looped forever due to routing errors. Routers decrement
-- -- the TTL of every datagram as it traverses from one network
-- -- to another and when its value reaches 0 the packet is
-- -- dropped. Default is 1.
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_TTL, 1));
--
-- -- Want the data you send to be looped back to your host.
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_Loop, True));
--
-- -- If this socket is intended to receive messages, bind it to a
-- -- given socket address.
--
-- Address.Addr := Any_Inet_Addr;
-- Address.Port := 55505;
--
-- Bind_Socket (Socket, Address);
--
-- -- If this socket is intended to send messages, provide the
-- -- receiver socket address.
--
-- Address.Addr := Inet_Addr (Group);
-- Address.Port := 55506;
--
-- Channel := Stream (Socket, Address);
--
-- -- Receive and print message from client Ping.
--
-- declare
-- Message : String := String'Input (Channel);
--
-- begin
--
-- -- Get the address of the sender.
--
-- Address := Get_Address (Channel);
-- Ada.Text_IO.Put_Line (Message & " from " & Image (Address));
--
-- -- Send same message to server Pong.
--
-- String'Output (Channel, Message);
-- end;
--
-- Close_Socket (Socket);
--
-- accept Stop;
--
-- exception when E : others =>
-- Ada.Text_IO.Put_Line
-- (Exception_Name (E) & ": " & Exception_Message (E));
-- end Pong;
--
-- task Ping is
-- entry Start;
-- entry Stop;
-- end Ping;
--
-- task body Ping is
-- Address : Sock_Addr_Type;
-- Socket : Socket_Type;
-- Channel : Stream_Access;
--
-- begin
-- accept Start;
--
-- -- See comments in Ping section for the first steps.
--
-- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1);
-- Address.Port := 5432;
-- Create_Socket (Socket);
--
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
--
-- -- Force Pong to block
--
-- delay 0.2;
--
-- -- If the client's socket is not bound, Connect_Socket will
-- -- bind to an unused address. The client uses Connect_Socket to
-- -- create a logical connection between the client's socket and
-- -- a server's socket returned by Accept_Socket.
--
-- Connect_Socket (Socket, Address);
--
-- Channel := Stream (Socket);
--
-- -- Send message to server Pong.
--
-- String'Output (Channel, "Hello world");
--
-- -- Force Ping to block
--
-- delay 0.2;
--
-- -- Receive and print message from server Pong.
--
-- Ada.Text_IO.Put_Line (String'Input (Channel));
-- Close_Socket (Socket);
--
-- -- Part of multicast example. Code similar to Pong's one.
--
-- Create_Socket (Socket, Family_Inet, Socket_Datagram);
--
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr));
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_TTL, 1));
--
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_Loop, True));
--
-- Address.Addr := Any_Inet_Addr;
-- Address.Port := 55506;
--
-- Bind_Socket (Socket, Address);
--
-- Address.Addr := Inet_Addr (Group);
-- Address.Port := 55505;
--
-- Channel := Stream (Socket, Address);
--
-- -- Send message to server Pong.
--
-- String'Output (Channel, "Hello world");
--
-- -- Receive and print message from server Pong.
--
-- declare
-- Message : String := String'Input (Channel);
--
-- begin
-- Address := Get_Address (Channel);
-- Ada.Text_IO.Put_Line (Message & " from " & Image (Address));
-- end;
--
-- Close_Socket (Socket);
--
-- accept Stop;
--
-- exception when E : others =>
-- Ada.Text_IO.Put_Line
-- (Exception_Name (E) & ": " & Exception_Message (E));
-- end Ping;
--
-- begin
-- -- Indicate whether the thread library provides process
-- -- blocking IO. Basically, if you are not using FSU threads
-- -- the default is ok.
--
-- Initialize (Process_Blocking_IO => False);
-- Ping.Start;
-- Pong.Start;
-- Ping.Stop;
-- Pong.Stop;
-- Finalize;
-- end PingPong;
procedure Initialize (Process_Blocking_IO : Boolean := False);
-- Initialize must be called before using any socket routines. If
-- the thread library provides process blocking IO - basically
-- with FSU threads - GNAT.Sockets should be initialized with a
-- value of True to simulate thread blocking IO. Further calls to
-- Initialize will be ignored.
procedure Finalize;
-- After Finalize is called it is not possible to use any routines
-- exported in by this package. This procedure is idempotent.
type Socket_Type is private;
-- Sockets are used to implement a reliable bi-directional
-- point-to-point, stream-based connections between
-- hosts. No_Socket provides a special value to denote
-- uninitialized sockets.
No_Socket : constant Socket_Type;
Socket_Error : exception;
-- There is only one exception in this package to deal with an
-- error during a socket routine. Once raised, its message
-- contains a string describing the error code.
function Image (Socket : Socket_Type) return String;
-- Return a printable string for Socket
function To_C (Socket : Socket_Type) return Integer;
-- Return a file descriptor to be used by external subprograms
-- especially the C functions that are not yet interfaced in this
-- package.
type Family_Type is (Family_Inet, Family_Inet6);
-- Address family (or protocol family) identifies the
-- communication domain and groups protocols with similar address
-- formats. IPv6 will soon be supported.
type Mode_Type is (Socket_Stream, Socket_Datagram);
-- Stream sockets provide connection-oriented byte
-- streams. Datagram sockets support unreliable connectionless
-- message based communication.
type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write);
-- When a process closes a socket, the policy is to retain any
-- data queued until either a delivery or a timeout expiration (in
-- this case, the data are discarded). A finer control is
-- available through shutdown. With Shut_Read, no more data can be
-- received from the socket. With_Write, no more data can be
-- transmitted. Neither transmission nor reception can be
-- performed with Shut_Read_Write.
type Port_Type is new Natural;
-- Classical port definition. No_Port provides a special value to
-- denote uninitialized port. Any_Port provides a special value
-- enabling all ports.
Any_Port : constant Port_Type;
No_Port : constant Port_Type;
type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private;
-- An Internet address depends on an address family (IPv4 contains
-- 4 octets and Ipv6 contains 16 octets). Any_Inet_Address is a
-- special value treated like a wildcard enabling all addresses.
-- No_Inet_Addr provides a special value to denote uninitialized
-- inet addresses.
Any_Inet_Addr : constant Inet_Addr_Type;
No_Inet_Addr : constant Inet_Addr_Type;
type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record
Addr : Inet_Addr_Type (Family);
Port : Port_Type;
end record;
-- Socket addresses fully define a socket connection with a
-- protocol family, an Internet address and a port. No_Sock_Addr
-- provides a special value for uninitialized socket addresses.
No_Sock_Addr : constant Sock_Addr_Type;
function Image (Value : Inet_Addr_Type) return String;
-- Return an image of an Internet address. IPv4 notation consists
-- in 4 octets in decimal format separated by dots. IPv6 notation
-- consists in 16 octets in hexadecimal format separated by
-- colons (and possibly dots).
function Image (Value : Sock_Addr_Type) return String;
-- Return inet address image and port image separated by a colon.
function Inet_Addr (Image : String) return Inet_Addr_Type;
-- Convert address image from numbers-and-dots notation into an
-- inet address.
-- Host entries provide a complete information on a given host:
-- the official name, an array of alternative names or aliases and
-- array of network addresses.
type Host_Entry_Type
(Aliases_Length, Addresses_Length : Natural) is private;
function Official_Name (E : Host_Entry_Type) return String;
-- Return official name in host entry
function Aliases_Length (E : Host_Entry_Type) return Natural;
-- Return number of aliases in host entry
function Addresses_Length (E : Host_Entry_Type) return Natural;
-- Return number of addresses in host entry
function Aliases
(E : Host_Entry_Type;
N : Positive := 1)
return String;
-- Return N'th aliases in host entry. The first index is 1.
function Addresses
(E : Host_Entry_Type;
N : Positive := 1)
return Inet_Addr_Type;
-- Return N'th addresses in host entry. The first index is 1.
Host_Error : exception;
-- Exception raised by the two following procedures. Once raised,
-- its message contains a string describing the error code. This
-- exception is raised when an host entry can not be retrieved.
function Get_Host_By_Address
(Address : Inet_Addr_Type;
Family : Family_Type := Family_Inet)
return Host_Entry_Type;
-- Return host entry structure for the given inet address
function Get_Host_By_Name
(Name : String)
return Host_Entry_Type;
-- Return host entry structure for the given host name
function Host_Name return String;
-- Return the name of the current host
-- Errors are described by an enumeration type. There is only one
-- exception Socket_Error in this package to deal with an error
-- during a socket routine. Once raised, its message contains the
-- error code between brackets and a string describing the error
-- code.
type Error_Type is
(Permission_Denied,
Address_Already_In_Use,
Cannot_Assign_Requested_Address,
Address_Family_Not_Supported_By_Protocol,
Operation_Already_In_Progress,
Bad_File_Descriptor,
Connection_Refused,
Bad_Address,
Operation_Now_In_Progress,
Interrupted_System_Call,
Invalid_Argument,
Input_Output_Error,
Transport_Endpoint_Already_Connected,
Message_Too_Long,
Network_Is_Unreachable,
No_Buffer_Space_Available,
Protocol_Not_Available,
Transport_Endpoint_Not_Connected,
Operation_Not_Supported,
Protocol_Not_Supported,
Socket_Type_Not_Supported,
Connection_Timed_Out,
Resource_Temporarily_Unavailable,
Unknown_Host,
Host_Name_Lookup_Failure,
No_Address_Associated_With_Name,
Unknown_Server_Error,
Cannot_Resolve_Error);
-- Get_Socket_Options and Set_Socket_Options manipulate options
-- associated with a socket. Options may exist at multiple
-- protocol levels in the communication stack. Socket_Level is the
-- uppermost socket level.
type Level_Type is (
Socket_Level,
IP_Protocol_For_IP_Level,
IP_Protocol_For_UDP_Level,
IP_Protocol_For_TCP_Level);
-- There are several options available to manipulate sockets. Each
-- option has a name and several values available. Most of the
-- time, the value is a boolean to enable or disable this option.
type Option_Name is (
Keep_Alive, -- Enable sending of keep-alive messages
Reuse_Address, -- Allow bind to reuse local address
Broadcast, -- Enable datagram sockets to recv/send broadcast packets
Send_Buffer, -- Set/get the maximum socket send buffer in bytes
Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes
Linger, -- Shutdown wait for msg to be sent or timeout occur
Error, -- Get and clear the pending socket error
No_Delay, -- Do not delay send to coalesce packets (TCP_NODELAY)
Add_Membership, -- Join a multicast group
Drop_Membership, -- Leave a multicast group
Multicast_TTL, -- Indicates the time-to-live of sent multicast packets
Multicast_Loop); -- Sent multicast packets are looped to the local socket
type Option_Type (Name : Option_Name := Keep_Alive) is record
case Name is
when Keep_Alive |
Reuse_Address |
Broadcast |
Linger |
No_Delay |
Multicast_Loop =>
Enabled : Boolean;
case Name is
when Linger =>
Seconds : Natural;
when others =>
null;
end case;
when Send_Buffer |
Receive_Buffer =>
Size : Natural;
when Error =>
Error : Error_Type;
when Add_Membership |
Drop_Membership =>
Multiaddr : Inet_Addr_Type;
Interface : Inet_Addr_Type;
when Multicast_TTL =>
Time_To_Live : Natural;
end case;
end record;
-- There are several controls available to manipulate
-- sockets. Each option has a name and several values available.
-- These controls differ from the socket options in that they are
-- not specific to sockets but are available for any device.
type Request_Name is (
Non_Blocking_IO, -- Cause a caller not to wait on blocking operations.
N_Bytes_To_Read); -- Return the number of bytes available to read
type Request_Type (Name : Request_Name := Non_Blocking_IO) is record
case Name is
when Non_Blocking_IO =>
Enabled : Boolean;
when N_Bytes_To_Read =>
Size : Natural;
end case;
end record;
procedure Create_Socket
(Socket : out Socket_Type;
Family : Family_Type := Family_Inet;
Mode : Mode_Type := Socket_Stream);
-- Create an endpoint for communication. Raise Socket_Error on error.
procedure Accept_Socket
(Server : Socket_Type;
Socket : out Socket_Type;
Address : out Sock_Addr_Type);
-- Extract the first connection request on the queue of pending
-- connections, creates a new connected socket with mostly the
-- same properties as Server, and allocates a new socket. The
-- returned Address is filled in with the address of the
-- connection. Raise Socket_Error on error.
procedure Bind_Socket
(Socket : Socket_Type;
Address : Sock_Addr_Type);
-- Once a socket is created, assign a local address to it. Raise
-- Socket_Error on error.
procedure Close_Socket (Socket : Socket_Type);
-- Close a socket and more specifically a non-connected socket.
-- Fail silently.
procedure Connect_Socket
(Socket : Socket_Type;
Server : in out Sock_Addr_Type);
-- Make a connection to another socket which has the address of
-- Server. Raise Socket_Error on error.
procedure Control_Socket
(Socket : Socket_Type;
Request : in out Request_Type);
-- Obtain or set parameter values that control the socket. This
-- control differs from the socket options in that they are not
-- specific to sockets but are avaiable for any device.
function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type;
-- Return the peer or remote socket address of a socket. Raise
-- Socket_Error on error.
function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type;
-- Return the local or current socket address of a socket. Raise
-- Socket_Error on error.
function Get_Socket_Option
(Socket : Socket_Type;
Level : Level_Type := Socket_Level;
Name : Option_Name)
return Option_Type;
-- Get the options associated with a socket. Raise Socket_Error on
-- error.
procedure Listen_Socket
(Socket : Socket_Type;
Length : Positive := 15);
-- To accept connections, a socket is first created with
-- Create_Socket, a willingness to accept incoming connections and
-- a queue Length for incoming connections are specified. Raise
-- Socket_Error on error.
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset);
-- Receive message from Socket. Last is the index value such that
-- Item (Last) is the last character assigned. Note that Last is
-- set to Item'First - 1 when the socket has been closed by
-- peer. This is not an error and no exception is raised. Raise
-- Socket_Error on error.
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
From : out Sock_Addr_Type);
-- Receive message from Socket. If Socket is not
-- connection-oriented, the source address From of the message is
-- filled in. Last is the index value such that Item (Last) is the
-- last character assigned. Raise Socket_Error on error.
function Resolve_Exception
(Occurrence : Ada.Exceptions.Exception_Occurrence)
return Error_Type;
-- When Socket_Error or Host_Error are raised, the exception
-- message contains the error code between brackets and a string
-- describing the error code. Resolve_Error extracts the error
-- code from an exception message and translate it into an
-- enumeration value.
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset);
-- Transmit a message to another socket. Note that Last is set to
-- Item'First when socket has been closed by peer. This is not an
-- error and no exception is raised. Raise Socket_Error on error;
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
To : Sock_Addr_Type);
-- Transmit a message to another socket. The address is given by
-- To. Raise Socket_Error on error;
procedure Set_Socket_Option
(Socket : Socket_Type;
Level : Level_Type := Socket_Level;
Option : Option_Type);
-- Manipulate socket options. Raise Socket_Error on error.
procedure Shutdown_Socket
(Socket : Socket_Type;
How : Shutmode_Type := Shut_Read_Write);
-- Shutdown a connected socket. If How is Shut_Read, further
-- receives will be disallowed. If How is Shut_Write, further
-- sends will be disallowed. If how is Shut_Read_Write, further
-- sends and receives will be disallowed. Fail silently.
type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
-- Same interface as Ada.Streams.Stream_IO
function Stream
(Socket : Socket_Type)
return Stream_Access;
-- Associate a stream with a stream-based socket that is already
-- connected.
function Stream
(Socket : Socket_Type;
Send_To : Sock_Addr_Type)
return Stream_Access;
-- Associate a stream with a datagram-based socket that is already
-- bound. Send_To is the socket address to which messages are
-- being sent.
function Get_Address
(Stream : Stream_Access)
return Sock_Addr_Type;
-- Return the socket address from which the last message was
-- received.
type Socket_Set_Type is private;
-- This type allows to manipulate sets of sockets. It allows to
-- wait for events on multiple endpoints at one time. This is an
-- access type on a system dependent structure. To avoid memory
-- leaks it is highly recommended to clean the access value with
-- procedure Empty.
procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type);
-- Remove Socket from Item
procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type);
-- Insert Socket into Item
procedure Empty (Item : in out Socket_Set_Type);
-- Remove all Sockets from Item and deallocate internal data
function Is_Empty
(Item : Socket_Set_Type)
return Boolean;
-- Return True if Item is empty
function Is_Set
(Item : Socket_Set_Type;
Socket : Socket_Type)
return Boolean;
-- Return True if Socket is present in Item
-- C select() waits for a number of file descriptors to change
-- status. Usually, three independant sets of descriptors are
-- watched (read, write and exception). A timeout gives an upper
-- bound on the amount of time elapsed before select returns.
-- This function blocks until an event occurs. On some platforms,
-- C select can block the full process.
--
-- Check_Selector provides the very same behaviour. The only
-- difference is that it does not watch for exception events. Note
-- that on some platforms it is kept process blocking in purpose.
-- The timeout parameter allows the user to have the behaviour he
-- wants. Abort_Selector allows to abort safely a Check_Selector
-- that is blocked forever. A special file descriptor is opened by
-- Create_Selector and included in each call to
-- Check_Selector. Abort_Selector causes an event to occur on this
-- descriptor in order to unblock Check_Selector. The user must
-- call Close_Selector to discard this special file. A reason to
-- abort a select operation is typically to add a socket in one of
-- the socket sets when the timeout is set to forever.
Forever : constant Duration;
type Selector_Type is limited private;
type Selector_Access is access all Selector_Type;
procedure Create_Selector (Selector : out Selector_Type);
-- Create a new selector
procedure Close_Selector (Selector : in out Selector_Type);
-- Close Selector and all internal descriptors associated
type Selector_Status is (Completed, Expired, Aborted);
procedure Check_Selector
(Selector : in out Selector_Type;
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
Timeout : Duration := Forever);
-- Return when one Socket in R_Socket_Set has some data to be read
-- or if one Socket in W_Socket_Set is ready to receive some
-- data. In these cases Status is set to Completed and sockets
-- that are ready are set in R_Socket_Set or W_Socket_Set. Status
-- is set to Expired if no socket was ready after a Timeout
-- expiration. Status is set to Aborted if an abort signal as been
-- received while checking socket status. As this procedure
-- returns when Timeout occurs, it is a design choice to keep this
-- procedure process blocking. Note that a Timeout of 0.0 returns
-- immediatly.
procedure Abort_Selector (Selector : Selector_Type);
-- Send an abort signal to the selector.
private
type Socket_Type is new Integer;
No_Socket : constant Socket_Type := -1;
Forever : constant Duration := Duration'Last;
type Selector_Type is limited record
R_Sig_Socket : Socket_Type;
W_Sig_Socket : Socket_Type;
In_Progress : Boolean := False;
end record;
-- The two signalling sockets are used to abort a select
-- operation.
type Socket_Set_Record;
type Socket_Set_Type is access all Socket_Set_Record;
subtype Inet_Addr_Comp_Type is Natural range 0 .. 255;
-- Octet for Internet address
type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type;
subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4);
subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16);
type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record
case Family is
when Family_Inet =>
Sin_V4 : Inet_Addr_V4_Type := (others => 0);
when Family_Inet6 =>
Sin_V6 : Inet_Addr_V6_Type := (others => 0);
end case;
end record;
Any_Port : constant Port_Type := 0;
No_Port : constant Port_Type := 0;
Any_Inet_Addr : constant Inet_Addr_Type := (Family_Inet, (others => 0));
No_Inet_Addr : constant Inet_Addr_Type := (Family_Inet, (others => 0));
No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0);
Max_Host_Name_Length : constant := 64;
-- The constant MAXHOSTNAMELEN is usually set to 64
subtype Host_Name_Index is Natural range 1 .. Max_Host_Name_Length;
type Host_Name_Type
(Length : Host_Name_Index := Max_Host_Name_Length)
is record
Name : String (1 .. Length);
end record;
-- We need fixed strings to avoid access types in host entry type
type Host_Name_Array is array (Natural range <>) of Host_Name_Type;
type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type;
type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record
Official : Host_Name_Type;
Aliases : Host_Name_Array (1 .. Aliases_Length);
Addresses : Inet_Addr_Array (1 .. Addresses_Length);
end record;
end GNAT.Sockets;

495
gcc/ada/g-socthi.adb Normal file
View File

@ -0,0 +1,495 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
-- operation. But the user can set a socket in non-blocking mode
-- by purpose. We track the socket in such a mode by redefining
-- C_Ioctl. In blocking IO operations, we exit normally when the
-- non-blocking flag is set by user, we poll and try later when
-- this flag is set automatically by this package.
type Socket_Info is record
Non_Blocking : Boolean := False;
end record;
Table : array (C.int range 0 .. 31) of Socket_Info;
-- Get info on blocking flag. This array is limited to 32 sockets
-- because the select operation allows socket set of less then 32
-- sockets.
Quantum : constant Duration := 0.2;
-- comment needed ???
Thread_Blocking_IO : Boolean := True;
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int)
return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int)
return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Ioctl
(S : C.int;
Req : C.int;
Arg : Int_Access)
return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int)
return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int;
pragma Import (C, Syscall_Send, "send");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
Tolen : C.int)
return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
(Domain, Typ, Protocol : C.int)
return C.int;
pragma Import (C, Syscall_Socket, "socket");
procedure Set_Non_Blocking (S : C.int);
--------------
-- C_Accept --
--------------
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Accept (S, Addr, Addrlen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
if not Thread_Blocking_IO
and then Res /= Failure
then
-- A socket inherits the properties ot its server especially
-- the FNDELAY flag.
Table (Res).Non_Blocking := Table (S).Non_Blocking;
Set_Non_Blocking (Res);
end if;
return Res;
end C_Accept;
---------------
-- C_Connect --
---------------
function C_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int)
return C.int
is
Res : C.int;
begin
Res := Syscall_Connect (S, Name, Namelen);
if Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EINPROGRESS
then
return Res;
end if;
declare
Set : aliased Fd_Set;
Now : aliased Timeval;
begin
loop
Set := 2 ** Natural (S);
Now := Immediat;
Res := C_Select
(S + 1,
null, Set'Unchecked_Access,
null, Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
return Res;
end if;
delay Quantum;
end loop;
end;
Res := Syscall_Connect (S, Name, Namelen);
if Res = Failure
and then Errno = Constants.EISCONN
then
return Thin.Success;
else
return Res;
end if;
end C_Connect;
-------------
-- C_Ioctl --
-------------
function C_Ioctl
(S : C.int;
Req : C.int;
Arg : Int_Access)
return C.int
is
begin
if not Thread_Blocking_IO
and then Req = Constants.FIONBIO
then
Table (S).Non_Blocking := (Arg.all /= 0);
end if;
return Syscall_Ioctl (S, Req, Arg);
end C_Ioctl;
------------
-- C_Recv --
------------
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recv (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recv;
----------------
-- C_Recvfrom --
----------------
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recvfrom;
------------
-- C_Send --
------------
function C_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Send (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Send;
--------------
-- C_Sendto --
--------------
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
Tolen : C.int)
return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
exit when Thread_Blocking_IO
or else Res /= Failure
or else Table (S).Non_Blocking
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Sendto;
--------------
-- C_Socket --
--------------
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int)
return C.int
is
Res : C.int;
begin
Res := Syscall_Socket (Domain, Typ, Protocol);
if not Thread_Blocking_IO
and then Res /= Failure
then
Set_Non_Blocking (Res);
end if;
return Res;
end C_Socket;
-----------
-- Clear --
-----------
procedure Clear
(Item : in out Fd_Set;
Socket : in C.int)
is
Mask : constant Fd_Set := 2 ** Natural (Socket);
begin
if (Item and Mask) /= 0 then
Item := Item xor Mask;
end if;
end Clear;
-----------
-- Empty --
-----------
procedure Empty (Item : in out Fd_Set) is
begin
Item := 0;
end Empty;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
null;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean) is
begin
Thread_Blocking_IO := not Process_Blocking_IO;
end Initialize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Item : Fd_Set) return Boolean is
begin
return Item = 0;
end Is_Empty;
------------
-- Is_Set --
------------
function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
begin
return (Item and 2 ** Natural (Socket)) /= 0;
end Is_Set;
---------
-- Max --
---------
function Max (Item : Fd_Set) return C.int
is
L : C.int := -1;
C : Fd_Set := Item;
begin
while C /= 0 loop
L := L + 1;
C := C / 2;
end loop;
return L;
end Max;
---------
-- Set --
---------
procedure Set (Item : in out Fd_Set; Socket : in C.int) is
begin
Item := Item or 2 ** Natural (Socket);
end Set;
----------------------
-- Set_Non_Blocking --
----------------------
procedure Set_Non_Blocking (S : C.int) is
Res : C.int;
Val : aliased C.int := 1;
begin
-- Do not use C_Fcntl because this subprogram tracks the
-- sockets set by user in non-blocking mode.
Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
end Set_Non_Blocking;
--------------------------
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message (Errno : Integer) return String is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : C.Strings.chars_ptr;
begin
C_Msg := C_Strerror (C.int (Errno));
if C_Msg = C.Strings.Null_Ptr then
return "Unknown system error";
else
return C.Strings.Value (C_Msg);
end if;
end Socket_Error_Message;
end GNAT.Sockets.Thin;

343
gcc/ada/g-socthi.ads Normal file
View File

@ -0,0 +1,343 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
with System;
package GNAT.Sockets.Thin is
-- ??? more comments needed ???
-- This package is intended for hosts implementing BSD sockets with a
-- standard interface. It will be used as a default for all the platforms
-- that do not have a specific version of this file.
package C renames Interfaces.C;
use type C.int;
-- This is so we can declare the Failure constant below
Success : constant C.int := 0;
Failure : constant C.int := -1;
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number.
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
type Fd_Set is mod 2 ** 32;
pragma Convention (C, Fd_Set);
Null_Fd_Set : constant Fd_Set := 0;
type Fd_Set_Access is access all Fd_Set;
pragma Convention (C, Fd_Set_Access);
type Timeval_Unit is new C.int;
pragma Convention (C, Timeval_Unit);
type Timeval is record
Tv_Sec : Timeval_Unit;
Tv_Usec : Timeval_Unit;
end record;
pragma Convention (C, Timeval);
type Timeval_Access is access all Timeval;
pragma Convention (C, Timeval_Access);
Immediat : constant Timeval := (0, 0);
type Int_Access is access all C.int;
pragma Convention (C, Int_Access);
-- Access to C integers
type Chars_Ptr_Array is array (C.size_t range <>) of
aliased C.Strings.chars_ptr;
package Chars_Ptr_Pointers is
new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array,
C.Strings.Null_Ptr);
-- Arrays of C (char *)
type In_Addr is record
S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
end record;
pragma Convention (C, In_Addr);
-- Internet address
type In_Addr_Access is access all In_Addr;
pragma Convention (C, In_Addr_Access);
-- Access to internet address
Inaddr_Any : aliased constant In_Addr := (others => 0);
-- Any internet address (all the interfaces)
type In_Addr_Access_Array is array (C.size_t range <>)
of aliased In_Addr_Access;
pragma Convention (C, In_Addr_Access_Array);
package In_Addr_Access_Pointers is
new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
-- Array of internet addresses
type Sockaddr is record
Sa_Family : C.unsigned_short;
Sa_Data : C.char_array (1 .. 14);
end record;
pragma Convention (C, Sockaddr);
-- Socket address
type Sockaddr_Access is access all Sockaddr;
pragma Convention (C, Sockaddr_Access);
-- Access to socket address
type Sockaddr_In is record
Sin_Family : C.unsigned_short := Constants.AF_INET;
Sin_Port : C.unsigned_short := 0;
Sin_Addr : In_Addr := Inaddr_Any;
Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0));
end record;
pragma Convention (C, Sockaddr_In);
-- Internet socket address
type Sockaddr_In_Access is access all Sockaddr_In;
pragma Convention (C, Sockaddr_In_Access);
-- Access to internet socket address
type Hostent is record
H_Name : C.Strings.chars_ptr;
H_Aliases : Chars_Ptr_Pointers.Pointer;
H_Addrtype : C.int;
H_Length : C.int;
H_Addr_List : In_Addr_Access_Pointers.Pointer;
end record;
pragma Convention (C, Hostent);
-- Host entry
type Hostent_Access is access all Hostent;
pragma Convention (C, Hostent_Access);
-- Access to host entry
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int)
return C.int;
function C_Bind
(S : C.int;
Name : System.Address;
Namelen : C.int)
return C.int;
function C_Close
(Fd : C.int)
return C.int;
function C_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int)
return C.int;
function C_Gethostbyaddr
(Addr : System.Address;
Len : C.int;
Typ : C.int)
return Hostent_Access;
function C_Gethostbyname
(Name : C.char_array)
return Hostent_Access;
function C_Gethostname
(Name : System.Address;
Namelen : C.int)
return C.int;
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : access C.int)
return C.int;
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : access C.int)
return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : access C.int)
return C.int;
function C_Inet_Addr
(Cp : C.Strings.chars_ptr)
return C.int;
function C_Ioctl
(S : C.int;
Req : C.int;
Arg : Int_Access)
return C.int;
function C_Listen (S, Backlog : C.int) return C.int;
function C_Read
(Fd : C.int;
Buf : System.Address;
Count : C.int)
return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int;
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int)
return C.int;
function C_Select
(Nfds : C.int;
Readfds : Fd_Set_Access;
Writefds : Fd_Set_Access;
Exceptfds : Fd_Set_Access;
Timeout : Timeval_Access)
return C.int;
function C_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int)
return C.int;
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : Sockaddr_In_Access;
Tolen : C.int)
return C.int;
function C_Setsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : C.int)
return C.int;
function C_Shutdown
(S : C.int;
How : C.int)
return C.int;
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int)
return C.int;
function C_Strerror
(Errnum : C.int)
return C.Strings.chars_ptr;
function C_System
(Command : System.Address)
return C.int;
function C_Write
(Fd : C.int;
Buf : System.Address;
Count : C.int)
return C.int;
-- Return highest numbered socket (what does this refer to???)
procedure Clear (Item : in out Fd_Set; Socket : in C.int);
procedure Empty (Item : in out Fd_Set);
function Is_Empty (Item : Fd_Set) return Boolean;
function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean;
function Max (Item : Fd_Set) return C.int;
procedure Set (Item : in out Fd_Set; Socket : in C.int);
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean);
private
pragma Import (C, C_Bind, "bind");
pragma Import (C, C_Close, "close");
pragma Import (C, C_Gethostbyaddr, "gethostbyaddr");
pragma Import (C, C_Gethostbyname, "gethostbyname");
pragma Import (C, C_Gethostname, "gethostname");
pragma Import (C, C_Getpeername, "getpeername");
pragma Import (C, C_Getsockname, "getsockname");
pragma Import (C, C_Getsockopt, "getsockopt");
pragma Import (C, C_Inet_Addr, "inet_addr");
pragma Import (C, C_Listen, "listen");
pragma Import (C, C_Read, "read");
pragma Import (C, C_Select, "select");
pragma Import (C, C_Setsockopt, "setsockopt");
pragma Import (C, C_Shutdown, "shutdown");
pragma Import (C, C_Strerror, "strerror");
pragma Import (C, C_System, "system");
pragma Import (C, C_Write, "write");
end GNAT.Sockets.Thin;

39
gcc/ada/g-soliop.ads Normal file
View File

@ -0,0 +1,39 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package GNAT.Sockets.Linker_Options is
-- Empty version of this package.
end GNAT.Sockets.Linker_Options;

77
gcc/ada/g-souinf.ads Normal file
View File

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . S O U R C E _ I N F O --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides some useful utility subprograms that provide access
-- to source code information known at compile time. These subprograms are
-- intrinsic operations that provide information known to the compiler in
-- a form that can be embedded into the source program for identification
-- and logging purposes. For example, an exception handler can print out
-- the name of the source file in which the exception is handled.
package GNAT.Source_Info is
pragma Pure (Source_Info);
function File return String;
-- Return the name of the current file, not including the path information.
-- The result is considered to be a static string constant.
function Line return Positive;
-- Return the current input line number. The result is considered
-- to be a static expression.
function Source_Location return String;
-- Return a string literal of the form "name:line", where name is the
-- current source file name without path information, and line is the
-- current line number. In the event that instantiations are involved,
-- additional suffixes of the same form are appended after the separating
-- string " instantiated at ". The result is considered to be a static
-- string constant.
function Enclosing_Entity return String;
-- Return the name of the current subprogram, package, task, entry or
-- protected subprogram. The string is in exactly the form used for the
-- declaration of the entity (casing and encoding conventions), and is
-- considered to be a static string constant.
--
-- Note: if this function is used at the outer level of a generic
-- package, the string returned will be the name of the instance,
-- not the generic package itself. This is useful in identifying
-- and logging information from within generic templates.
private
pragma Import (Intrinsic, File);
pragma Import (Intrinsic, Line);
pragma Import (Intrinsic, Source_Location);
pragma Import (Intrinsic, Enclosing_Entity);
end GNAT.Source_Info;

156
gcc/ada/g-speche.adb Normal file
View File

@ -0,0 +1,156 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . S P E L L I N G _ C H E C K E R --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body GNAT.Spelling_Checker is
------------------------
-- Is_Bad_Spelling_Of --
------------------------
function Is_Bad_Spelling_Of
(Found : String;
Expect : String)
return Boolean
is
FN : constant Natural := Found'Length;
FF : constant Natural := Found'First;
FL : constant Natural := Found'Last;
EN : constant Natural := Expect'Length;
EF : constant Natural := Expect'First;
EL : constant Natural := Expect'Last;
begin
-- If both strings null, then we consider this a match, but if one
-- is null and the other is not, then we definitely do not match
if FN = 0 then
return (EN = 0);
elsif EN = 0 then
return False;
-- If first character does not match, then definitely not misspelling
elsif Found (FF) /= Expect (EF) then
return False;
-- Not a bad spelling if both strings are 1-2 characters long
elsif FN < 3 and then EN < 3 then
return False;
-- Lengths match. Execute loop to check for a single error, single
-- transposition or exact match (we only fall through this loop if
-- one of these three conditions is found).
elsif FN = EN then
for J in 1 .. FN - 2 loop
if Expect (EF + J) /= Found (FF + J) then
-- If both mismatched characters are digits, then we do
-- not consider it a misspelling (e.g. B345 is not a
-- misspelling of B346, it is something quite different)
if Expect (EF + J) in '0' .. '9'
and then Found (FF + J) in '0' .. '9'
then
return False;
elsif Expect (EF + J + 1) = Found (FF + J + 1)
and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL)
then
return True;
elsif Expect (EF + J) = Found (FF + J + 1)
and then Expect (EF + J + 1) = Found (FF + J)
and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL)
then
return True;
else
return False;
end if;
end if;
end loop;
-- At last character. Test digit case as above, otherwise we
-- have a match since at most this last character fails to match.
if Expect (EL) in '0' .. '9'
and then Found (FL) in '0' .. '9'
and then Expect (EL) /= Found (FL)
then
return False;
else
return True;
end if;
-- Length is 1 too short. Execute loop to check for single deletion
elsif FN = EN - 1 then
for J in 1 .. FN - 1 loop
if Found (FF + J) /= Expect (EF + J) then
return Found (FF + J .. FL) = Expect (EF + J + 1 .. EL);
end if;
end loop;
-- If we fall through then the last character was missing, which
-- we consider to be a match (e.g. found xyz, expected xyza).
return True;
-- Length is 1 too long. Execute loop to check for single insertion
elsif FN = EN + 1 then
for J in 1 .. FN - 1 loop
if Found (FF + J) /= Expect (EF + J) then
return Found (FF + J + 1 .. FL) = Expect (EF + J .. EL);
end if;
end loop;
-- If we fall through then the last character was an additional
-- character, which is a match (e.g. found xyza, expected xyz).
return True;
-- Length is completely wrong
else
return False;
end if;
end Is_Bad_Spelling_Of;
end GNAT.Spelling_Checker;

58
gcc/ada/g-speche.ads Normal file
View File

@ -0,0 +1,58 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . S P E L L I N G _ C H E C K E R --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (C) 1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Spelling checker
-- This package provides a utility routine for checking for bad spellings
package GNAT.Spelling_Checker is
pragma Pure (Spelling_Checker);
function Is_Bad_Spelling_Of
(Found : String;
Expect : String)
return Boolean;
-- Determines if the string Found is a plausible misspelling of the
-- string Expect. Returns True for an exact match or a probably
-- misspelling, False if no near match is detected. This routine
-- is case sensitive, so the caller should fold both strings to
-- get a case insensitive match.
--
-- Note: the spec of this routine is deliberately rather vague. This
-- routine is the one used by GNAT itself to detect misspelled keywords
-- and identifiers, and is heuristically adjusted to be appropriate to
-- this usage. It will work well in any similar case of named entities
-- with relatively short mnemonic names.
end GNAT.Spelling_Checker;

6328
gcc/ada/g-spipat.adb Normal file
View File

File diff suppressed because it is too large Load Diff

1204
gcc/ada/g-spipat.ads Normal file
View File

File diff suppressed because it is too large Load Diff

764
gcc/ada/g-spitbo.adb Normal file
View File

@ -0,0 +1,764 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . S P I T B O L --
-- --
-- B o d y --
-- --
-- $Revision: 1.15 $ --
-- --
-- Copyright (C) 1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
with GNAT.IO; use GNAT.IO;
with Unchecked_Deallocation;
package body GNAT.Spitbol is
---------
-- "&" --
---------
function "&" (Num : Integer; Str : String) return String is
begin
return S (Num) & Str;
end "&";
function "&" (Str : String; Num : Integer) return String is
begin
return Str & S (Num);
end "&";
function "&" (Num : Integer; Str : VString) return VString is
begin
return S (Num) & Str;
end "&";
function "&" (Str : VString; Num : Integer) return VString is
begin
return Str & S (Num);
end "&";
----------
-- Char --
----------
function Char (Num : Natural) return Character is
begin
return Character'Val (Num);
end Char;
----------
-- Lpad --
----------
function Lpad
(Str : VString;
Len : Natural;
Pad : Character := ' ')
return VString
is
begin
if Length (Str) >= Len then
return Str;
else
return Tail (Str, Len, Pad);
end if;
end Lpad;
function Lpad
(Str : String;
Len : Natural;
Pad : Character := ' ')
return VString
is
begin
if Str'Length >= Len then
return V (Str);
else
declare
R : String (1 .. Len);
begin
for J in 1 .. Len - Str'Length loop
R (J) := Pad;
end loop;
R (Len - Str'Length + 1 .. Len) := Str;
return V (R);
end;
end if;
end Lpad;
procedure Lpad
(Str : in out VString;
Len : Natural;
Pad : Character := ' ')
is
begin
if Length (Str) >= Len then
return;
else
Tail (Str, Len, Pad);
end if;
end Lpad;
-------
-- N --
-------
function N (Str : VString) return Integer is
begin
return Integer'Value (Get_String (Str).all);
end N;
--------------------
-- Reverse_String --
--------------------
function Reverse_String (Str : VString) return VString is
Len : constant Natural := Length (Str);
Result : String (1 .. Len);
Chars : String_Access := Get_String (Str);
begin
for J in 1 .. Len loop
Result (J) := Chars (Len + 1 - J);
end loop;
return V (Result);
end Reverse_String;
function Reverse_String (Str : String) return VString is
Result : String (1 .. Str'Length);
begin
for J in 1 .. Str'Length loop
Result (J) := Str (Str'Last + 1 - J);
end loop;
return V (Result);
end Reverse_String;
procedure Reverse_String (Str : in out VString) is
Len : constant Natural := Length (Str);
Chars : String_Access := Get_String (Str);
Temp : Character;
begin
for J in 1 .. Len / 2 loop
Temp := Chars (J);
Chars (J) := Chars (Len + 1 - J);
Chars (Len + 1 - J) := Temp;
end loop;
end Reverse_String;
----------
-- Rpad --
----------
function Rpad
(Str : VString;
Len : Natural;
Pad : Character := ' ')
return VString
is
begin
if Length (Str) >= Len then
return Str;
else
return Head (Str, Len, Pad);
end if;
end Rpad;
function Rpad
(Str : String;
Len : Natural;
Pad : Character := ' ')
return VString
is
begin
if Str'Length >= Len then
return V (Str);
else
declare
R : String (1 .. Len);
begin
for J in Str'Length + 1 .. Len loop
R (J) := Pad;
end loop;
R (1 .. Str'Length) := Str;
return V (R);
end;
end if;
end Rpad;
procedure Rpad
(Str : in out VString;
Len : Natural;
Pad : Character := ' ')
is
begin
if Length (Str) >= Len then
return;
else
Head (Str, Len, Pad);
end if;
end Rpad;
-------
-- S --
-------
function S (Num : Integer) return String is
Buf : String (1 .. 30);
Ptr : Natural := Buf'Last + 1;
Val : Natural := abs (Num);
begin
loop
Ptr := Ptr - 1;
Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
Val := Val / 10;
exit when Val = 0;
end loop;
if Num < 0 then
Ptr := Ptr - 1;
Buf (Ptr) := '-';
end if;
return Buf (Ptr .. Buf'Last);
end S;
------------
-- Substr --
------------
function Substr
(Str : VString;
Start : Positive;
Len : Natural)
return VString
is
begin
if Start > Length (Str) then
raise Index_Error;
elsif Start + Len - 1 > Length (Str) then
raise Length_Error;
else
return V (Get_String (Str).all (Start .. Start + Len - 1));
end if;
end Substr;
function Substr
(Str : String;
Start : Positive;
Len : Natural)
return VString
is
begin
if Start > Str'Length then
raise Index_Error;
elsif Start + Len > Str'Length then
raise Length_Error;
else
return
V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
end if;
end Substr;
-----------
-- Table --
-----------
package body Table is
procedure Free is new
Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
-----------------------
-- Local Subprograms --
-----------------------
function Hash (Str : String) return Unsigned_32;
-- Compute hash function for given String
------------
-- Adjust --
------------
procedure Adjust (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
begin
for J in Object.Elmts'Range loop
Ptr1 := Object.Elmts (J)'Unrestricted_Access;
if Ptr1.Name /= null then
loop
Ptr1.Name := new String'(Ptr1.Name.all);
exit when Ptr1.Next = null;
Ptr2 := Ptr1.Next;
Ptr1.Next := new Hash_Element'(Ptr2.all);
Ptr1 := Ptr1.Next;
end loop;
end if;
end loop;
end Adjust;
-----------
-- Clear --
-----------
procedure Clear (T : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
begin
for J in T.Elmts'Range loop
if T.Elmts (J).Name /= null then
Free (T.Elmts (J).Name);
T.Elmts (J).Value := Null_Value;
Ptr1 := T.Elmts (J).Next;
T.Elmts (J).Next := null;
while Ptr1 /= null loop
Ptr2 := Ptr1.Next;
Free (Ptr1.Name);
Free (Ptr1);
Ptr1 := Ptr2;
end loop;
end if;
end loop;
end Clear;
----------------------
-- Convert_To_Array --
----------------------
function Convert_To_Array (T : Table) return Table_Array is
Num_Elmts : Natural := 0;
Elmt : Hash_Element_Ptr;
begin
for J in T.Elmts'Range loop
Elmt := T.Elmts (J)'Unrestricted_Access;
if Elmt.Name /= null then
loop
Num_Elmts := Num_Elmts + 1;
Elmt := Elmt.Next;
exit when Elmt = null;
end loop;
end if;
end loop;
declare
TA : Table_Array (1 .. Num_Elmts);
P : Natural := 1;
begin
for J in T.Elmts'Range loop
Elmt := T.Elmts (J)'Unrestricted_Access;
if Elmt.Name /= null then
loop
Set_String (TA (P).Name, Elmt.Name.all);
TA (P).Value := Elmt.Value;
P := P + 1;
Elmt := Elmt.Next;
exit when Elmt = null;
end loop;
end if;
end loop;
return TA;
end;
end Convert_To_Array;
----------
-- Copy --
----------
procedure Copy (From : in Table; To : in out Table) is
Elmt : Hash_Element_Ptr;
begin
Clear (To);
for J in From.Elmts'Range loop
Elmt := From.Elmts (J)'Unrestricted_Access;
if Elmt.Name /= null then
loop
Set (To, Elmt.Name.all, Elmt.Value);
Elmt := Elmt.Next;
exit when Elmt = null;
end loop;
end if;
end loop;
end Copy;
------------
-- Delete --
------------
procedure Delete (T : in out Table; Name : Character) is
begin
Delete (T, String'(1 => Name));
end Delete;
procedure Delete (T : in out Table; Name : VString) is
begin
Delete (T, Get_String (Name).all);
end Delete;
procedure Delete (T : in out Table; Name : String) is
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
Next : Hash_Element_Ptr;
begin
if Elmt.Name = null then
null;
elsif Elmt.Name.all = Name then
Free (Elmt.Name);
if Elmt.Next = null then
Elmt.Value := Null_Value;
return;
else
Next := Elmt.Next;
Elmt.Name := Next.Name;
Elmt.Value := Next.Value;
Elmt.Next := Next.Next;
Free (Next);
return;
end if;
else
loop
Next := Elmt.Next;
if Next = null then
return;
elsif Next.Name.all = Name then
Free (Next.Name);
Elmt.Next := Next.Next;
Free (Next);
return;
else
Elmt := Next;
end if;
end loop;
end if;
end Delete;
----------
-- Dump --
----------
procedure Dump (T : Table; Str : String := "Table") is
Num_Elmts : Natural := 0;
Elmt : Hash_Element_Ptr;
begin
for J in T.Elmts'Range loop
Elmt := T.Elmts (J)'Unrestricted_Access;
if Elmt.Name /= null then
loop
Num_Elmts := Num_Elmts + 1;
Put_Line
(Str & '<' & Image (Elmt.Name.all) & "> = " &
Img (Elmt.Value));
Elmt := Elmt.Next;
exit when Elmt = null;
end loop;
end if;
end loop;
if Num_Elmts = 0 then
Put_Line (Str & " is empty");
end if;
end Dump;
procedure Dump (T : Table_Array; Str : String := "Table_Array") is
begin
if T'Length = 0 then
Put_Line (Str & " is empty");
else
for J in T'Range loop
Put_Line
(Str & '(' & Image (To_String (T (J).Name)) & ") = " &
Img (T (J).Value));
end loop;
end if;
end Dump;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
begin
for J in Object.Elmts'Range loop
Ptr1 := Object.Elmts (J).Next;
Free (Object.Elmts (J).Name);
while Ptr1 /= null loop
Ptr2 := Ptr1.Next;
Free (Ptr1.Name);
Free (Ptr1);
Ptr1 := Ptr2;
end loop;
end loop;
end Finalize;
---------
-- Get --
---------
function Get (T : Table; Name : Character) return Value_Type is
begin
return Get (T, String'(1 => Name));
end Get;
function Get (T : Table; Name : VString) return Value_Type is
begin
return Get (T, Get_String (Name).all);
end Get;
function Get (T : Table; Name : String) return Value_Type is
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
begin
if Elmt.Name = null then
return Null_Value;
else
loop
if Name = Elmt.Name.all then
return Elmt.Value;
else
Elmt := Elmt.Next;
if Elmt = null then
return Null_Value;
end if;
end if;
end loop;
end if;
end Get;
----------
-- Hash --
----------
function Hash (Str : String) return Unsigned_32 is
Result : Unsigned_32 := Str'Length;
begin
for J in Str'Range loop
Result := Rotate_Left (Result, 1) +
Unsigned_32 (Character'Pos (Str (J)));
end loop;
return Result;
end Hash;
-------------
-- Present --
-------------
function Present (T : Table; Name : Character) return Boolean is
begin
return Present (T, String'(1 => Name));
end Present;
function Present (T : Table; Name : VString) return Boolean is
begin
return Present (T, Get_String (Name).all);
end Present;
function Present (T : Table; Name : String) return Boolean is
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
begin
if Elmt.Name = null then
return False;
else
loop
if Name = Elmt.Name.all then
return True;
else
Elmt := Elmt.Next;
if Elmt = null then
return False;
end if;
end if;
end loop;
end if;
end Present;
---------
-- Set --
---------
procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
begin
Set (T, Get_String (Name).all, Value);
end Set;
procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
begin
Set (T, String'(1 => Name), Value);
end Set;
procedure Set
(T : in out Table;
Name : String;
Value : Value_Type)
is
begin
if Value = Null_Value then
Delete (T, Name);
else
declare
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
subtype String1 is String (1 .. Name'Length);
begin
if Elmt.Name = null then
Elmt.Name := new String'(String1 (Name));
Elmt.Value := Value;
return;
else
loop
if Name = Elmt.Name.all then
Elmt.Value := Value;
return;
elsif Elmt.Next = null then
Elmt.Next := new Hash_Element'(
Name => new String'(String1 (Name)),
Value => Value,
Next => null);
return;
else
Elmt := Elmt.Next;
end if;
end loop;
end if;
end;
end if;
end Set;
end Table;
----------
-- Trim --
----------
function Trim (Str : VString) return VString is
begin
return Trim (Str, Right);
end Trim;
function Trim (Str : String) return VString is
begin
for J in reverse Str'Range loop
if Str (J) /= ' ' then
return V (Str (Str'First .. J));
end if;
end loop;
return Nul;
end Trim;
procedure Trim (Str : in out VString) is
begin
Trim (Str, Right);
end Trim;
-------
-- V --
-------
function V (Num : Integer) return VString is
Buf : String (1 .. 30);
Ptr : Natural := Buf'Last + 1;
Val : Natural := abs (Num);
begin
loop
Ptr := Ptr - 1;
Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
Val := Val / 10;
exit when Val = 0;
end loop;
if Num < 0 then
Ptr := Ptr - 1;
Buf (Ptr) := '-';
end if;
return V (Buf (Ptr .. Buf'Last));
end V;
end GNAT.Spitbol;

403
gcc/ada/g-spitbo.ads Normal file
View File

@ -0,0 +1,403 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . S P I T B O L --
-- --
-- S p e c --
-- --
-- $Revision: 1.18 $ --
-- --
-- Copyright (C) 1997-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- SPITBOL-like interface facilities
-- This package provides a set of interfaces to semantic operations copied
-- from SPITBOL, including a complete implementation of SPITBOL pattern
-- matching. The code is derived from the original SPITBOL MINIMAL sources,
-- created by Robert Dewar. The translation is not exact, but the
-- algorithmic approaches are similar.
with Ada.Finalization; use Ada.Finalization;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Interfaces; use Interfaces;
package GNAT.Spitbol is
pragma Preelaborate (Spitbol);
-- The Spitbol package relies heavily on the Unbounded_String package,
-- using the synonym VString for variable length string. The following
-- declarations define this type and other useful abbreviations.
subtype VString is Ada.Strings.Unbounded.Unbounded_String;
function V (Source : String) return VString
renames Ada.Strings.Unbounded.To_Unbounded_String;
function S (Source : VString) return String
renames Ada.Strings.Unbounded.To_String;
Nul : VString renames Ada.Strings.Unbounded.Null_Unbounded_String;
-------------------------
-- Facilities Provided --
-------------------------
-- The SPITBOL support in GNAT consists of this package together with
-- several child packages. In this package, we have first a set of
-- useful string functions, copied exactly from the corresponding
-- SPITBOL functions, except that we had to rename REVERSE because
-- reverse is a reserved word (it is now Reverse_String).
-- The second element of the parent package is a generic implementation
-- of a table facility. In SPITBOL, the TABLE function allows general
-- mappings from any datatype to any other datatype, and of course, as
-- always, we can freely mix multiple types in the same table.
-- The Ada version of tables is strongly typed, so the indexing type and
-- the range type are always of a consistent type. In this implementation
-- we only provide VString as an indexing type, since this is by far the
-- most common case. The generic instantiation specifies the range type
-- to be used.
-- Three child packages provide standard instantiations of this table
-- package for three common datatypes:
-- GNAT.Spitbol.Table_Boolean (file g-sptabo.ads)
-- The range type is Boolean. The default value is False. This
-- means that this table is essentially a representation of a set.
-- GNAT.Spitbol.Table_Integer (file g-sptain.ads)
-- The range type is Integer. The default value is Integer'First.
-- This provides a general mapping from strings to integers.
-- GNAT.Spitbol.Table_VString (file g-sptavs.ads)
-- The range type is VString. The default value is the null string.
-- This provides a general mapping from strings to strings.
-- Finally there is another child package:
-- GNAT.Spitbol.Patterns (file g-spipat.ads)
-- This child package provides a complete implementation of SPITBOL
-- pattern matching. The spec contains a complete tutorial on the
-- use of pattern matching.
---------------------------------
-- Standard String Subprograms --
---------------------------------
-- This section contains some operations on unbounded strings that are
-- closely related to those in the package Unbounded.Strings, but they
-- correspond to the SPITBOL semantics for these operations.
function Char (Num : Natural) return Character;
pragma Inline (Char);
-- Equivalent to Character'Val (Num)
function Lpad
(Str : VString;
Len : Natural;
Pad : Character := ' ')
return VString;
function Lpad
(Str : String;
Len : Natural;
Pad : Character := ' ')
return VString;
-- If the length of Str is greater than or equal to Len, then Str is
-- returned unchanged. Otherwise, The value returned is obtained by
-- concatenating Length (Str) - Len instances of the Pad character to
-- the left hand side.
procedure Lpad
(Str : in out VString;
Len : Natural;
Pad : Character := ' ');
-- The procedure form is identical to the function form, except that
-- the result overwrites the input argument Str.
function Reverse_String (Str : VString) return VString;
function Reverse_String (Str : String) return VString;
-- Returns result of reversing the string Str, i.e. the result returned
-- is a mirror image (end-for-end reversal) of the input string.
procedure Reverse_String (Str : in out VString);
-- The procedure form is identical to the function form, except that the
-- result overwrites the input argument Str.
function Rpad
(Str : VString;
Len : Natural;
Pad : Character := ' ')
return VString;
function Rpad
(Str : String;
Len : Natural;
Pad : Character := ' ')
return VString;
-- If the length of Str is greater than or equal to Len, then Str is
-- returned unchanged. Otherwise, The value returned is obtained by
-- concatenating Length (Str) - Len instances of the Pad character to
-- the right hand side.
procedure Rpad
(Str : in out VString;
Len : Natural;
Pad : Character := ' ');
-- The procedure form is identical to the function form, except that the
-- result overwrites the input argument Str.
function Size (Source : VString) return Natural
renames Ada.Strings.Unbounded.Length;
function Substr
(Str : VString;
Start : Positive;
Len : Natural)
return VString;
function Substr
(Str : String;
Start : Positive;
Len : Natural)
return VString;
-- Returns the substring starting at the given character position (which
-- is always counted from the start of the string, regardless of bounds,
-- e.g. 2 means starting with the second character of the string), and
-- with the length (Len) given. Indexing_Error is raised if the starting
-- position is out of range, and Length_Error is raised if Len is too long.
function Trim (Str : VString) return VString;
function Trim (Str : String) return VString;
-- Returns the string obtained by removing all spaces from the right
-- hand side of the string Str.
procedure Trim (Str : in out VString);
-- The procedure form is identical to the function form, except that the
-- result overwrites the input argument Str.
-----------------------
-- Utility Functions --
-----------------------
-- In SPITBOL, integer values can be freely treated as strings. The
-- following definitions help provide some of this capability in
-- some common cases.
function "&" (Num : Integer; Str : String) return String;
function "&" (Str : String; Num : Integer) return String;
function "&" (Num : Integer; Str : VString) return VString;
function "&" (Str : VString; Num : Integer) return VString;
-- In all these concatenation operations, the integer is converted to
-- its corresponding decimal string form, with no leading blank.
function S (Num : Integer) return String;
function V (Num : Integer) return VString;
-- These operators return the given integer converted to its decimal
-- string form with no leading blank.
function N (Str : VString) return Integer;
-- Converts string to number (same as Integer'Value (S (Str)))
-------------------
-- Table Support --
-------------------
-- So far, we only provide support for tables whose indexing data values
-- are strings (or unbounded strings). The values stored may be of any
-- type, as supplied by the generic formal parameter.
generic
type Value_Type is private;
-- Any non-limited type can be used as the value type in the table
Null_Value : Value_Type;
-- Value used to represent a value that is not present in the table.
with function Img (A : Value_Type) return String;
-- Used to provide image of value in Dump procedure
with function "=" (A, B : Value_Type) return Boolean is <>;
-- This allows a user-defined equality function to override the
-- predefined equality function.
package Table is
------------------------
-- Table Declarations --
------------------------
type Table (N : Unsigned_32) is private;
-- This is the table type itself. A table is a mapping from string
-- values to values of Value_Type. The discriminant is an estimate of
-- the number of values in the table. If the estimate is much too
-- high, some space is wasted, if the estimate is too low, access to
-- table elements is slowed down. The type Table has copy semantics,
-- not reference semantics. This means that if a table is copied
-- using simple assignment, then the two copies refer to entirely
-- separate tables.
-----------------------------
-- Table Access Operations --
-----------------------------
function Get (T : Table; Name : VString) return Value_Type;
function Get (T : Table; Name : Character) return Value_Type;
pragma Inline (Get);
function Get (T : Table; Name : String) return Value_Type;
-- If an entry with the given name exists in the table, then the
-- corresponding Value_Type value is returned. Otherwise Null_Value
-- is returned.
function Present (T : Table; Name : VString) return Boolean;
function Present (T : Table; Name : Character) return Boolean;
pragma Inline (Present);
function Present (T : Table; Name : String) return Boolean;
-- Determines if an entry with the given name is present in the table.
-- A returned value of True means that it is in the table, otherwise
-- False indicates that it is not in the table.
procedure Delete (T : in out Table; Name : VString);
procedure Delete (T : in out Table; Name : Character);
pragma Inline (Delete);
procedure Delete (T : in out Table; Name : String);
-- Deletes the table element with the given name from the table. If
-- no element in the table has this name, then the call has no effect.
procedure Set (T : in out Table; Name : VString; Value : Value_Type);
procedure Set (T : in out Table; Name : Character; Value : Value_Type);
pragma Inline (Set);
procedure Set (T : in out Table; Name : String; Value : Value_Type);
-- Sets the value of the element with the given name to the given
-- value. If Value is equal to Null_Value, the effect is to remove
-- the entry from the table. If no element with the given name is
-- currently in the table, then a new element with the given value
-- is created.
----------------------------
-- Allocation and Copying --
----------------------------
-- Table is a controlled type, so that all storage associated with
-- tables is properly reclaimed when a Table value is abandoned.
-- Tables have value semantics rather than reference semantics as
-- in Spitbol, i.e. when you assign a copy you end up with two
-- distinct copies of the table, as though COPY had been used in
-- Spitbol. It seems clearly more appropriate in Ada to require
-- the use of explicit pointers for reference semantics.
procedure Clear (T : in out Table);
-- Clears all the elements of the given table, freeing associated
-- storage. On return T is an empty table with no elements.
procedure Copy (From : in Table; To : in out Table);
-- First all the elements of table To are cleared (as described for
-- the Clear procedure above), then all the elements of table From
-- are copied into To. In the case where the tables From and To have
-- the same declared size (i.e. the same discriminant), the call to
-- Copy has the same effect as the assignment of From to To. The
-- difference is that, unlike the assignment statement, which will
-- cause a Constraint_Error if the source and target are of different
-- sizes, Copy works fine with different sized tables.
----------------
-- Conversion --
----------------
type Table_Entry is record
Name : VString;
Value : Value_Type;
end record;
type Table_Array is array (Positive range <>) of Table_Entry;
function Convert_To_Array (T : Table) return Table_Array;
-- Returns a Table_Array value with a low bound of 1, and a length
-- corresponding to the number of elements in the table. The elements
-- of the array give the elements of the table in unsorted order.
---------------
-- Debugging --
---------------
procedure Dump (T : Table; Str : String := "Table");
-- Dump contents of given table to the standard output file. The
-- string value Str is used as the name of the table in the dump.
procedure Dump (T : Table_Array; Str : String := "Table_Array");
-- Dump contents of given table array to the current output file. The
-- string value Str is used as the name of the table array in the dump.
private
------------------
-- Private Part --
------------------
-- A Table is a pointer to a hash table which contains the indicated
-- number of hash elements (the number is forced to the next odd value
-- if it is even to improve hashing performance). If more than one
-- of the entries in a table hashes to the same slot, the Next field
-- is used to chain entries from the header. The chains are not kept
-- ordered. A chain is terminated by a null pointer in Next. An unused
-- chain is marked by an element whose Name is null and whose value
-- is Null_Value.
type Hash_Element;
type Hash_Element_Ptr is access all Hash_Element;
type Hash_Element is record
Name : String_Access := null;
Value : Value_Type := Null_Value;
Next : Hash_Element_Ptr := null;
end record;
type Hash_Table is
array (Unsigned_32 range <>) of aliased Hash_Element;
type Table (N : Unsigned_32) is new Controlled with record
Elmts : Hash_Table (1 .. N);
end record;
pragma Finalize_Storage_Only (Table);
procedure Adjust (Object : in out Table);
-- The Adjust procedure does a deep copy of the table structure
-- so that the effect of assignment is, like other assignments
-- in Ada, value-oriented.
procedure Finalize (Object : in out Table);
-- This is the finalization routine that ensures that all storage
-- associated with a table is properly released when a table object
-- is abandoned and finalized.
end Table;
end GNAT.Spitbol;

44
gcc/ada/g-sptabo.ads Normal file
View File

@ -0,0 +1,44 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . S P I T B O L . T A B L E _ B O O L E A N --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1997-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- SPITBOL tables with boolean values (sets)
-- This package provides a predefined instantiation of the table abstraction
-- for type Standard.Boolean. The null value is False, so the only non-null
-- value is True, i.e. this table acts essentially as a set representation.
-- This package is based on Macro-SPITBOL created by Robert Dewar.
package GNAT.Spitbol.Table_Boolean is new
GNAT.Spitbol.Table (Boolean, False, Boolean'Image);
pragma Preelaborate (Table_Boolean);

44
gcc/ada/g-sptain.ads Normal file
View File

@ -0,0 +1,44 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . S P I T B O L . T A B L E _ I N T E G E R --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1997-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- SPITBOL tables with integer values
-- This package provides a predefined instantiation of the table abstraction
-- for type Standard.Integer. The largest negative integer is used as the
-- null value for the table. This package is based on Macro-SPITBOL created
-- by Robert Dewar.
package GNAT.Spitbol.Table_Integer is
new GNAT.Spitbol.Table (Integer, Integer'First, Integer'Image);
pragma Preelaborate (Table_Integer);

43
gcc/ada/g-sptavs.ads Normal file
View File

@ -0,0 +1,43 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . S P I T B O L . T A B L E _ V S T R I N G --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1997-1998 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- SPITBOL tables with vstring (unbounded string) values
-- This package provides a predefined instantiation of the table abstraction
-- for type VString (Ada.Strings.Unbounded.Unbounded_String). This package
-- is based on Macro-SPITBOL created by Robert Dewar.
package GNAT.Spitbol.Table_VString is new
GNAT.Spitbol.Table (VString, Nul, To_String);
pragma Preelaborate (Table_VString);

266
gcc/ada/g-table.adb Normal file
View File

@ -0,0 +1,266 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . T A B L E --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System; use System;
package body GNAT.Table is
Min : constant Integer := Integer (Table_Low_Bound);
-- Subscript of the minimum entry in the currently allocated table
Max : Integer;
-- Subscript of the maximum entry in the currently allocated table
Length : Integer := 0;
-- Number of entries in currently allocated table. The value of zero
-- ensures that we initially allocate the table.
Last_Val : Integer;
-- Current value of Last.
type size_t is new Integer;
-----------------------
-- Local Subprograms --
-----------------------
procedure Reallocate;
-- Reallocate the existing table according to the current value stored
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
--------------
-- Allocate --
--------------
function Allocate (Num : Integer := 1) return Table_Index_Type is
Old_Last : constant Integer := Last_Val;
begin
Last_Val := Last_Val + Num;
if Last_Val > Max then
Reallocate;
end if;
return Table_Index_Type (Old_Last + 1);
end Allocate;
------------
-- Append --
------------
procedure Append (New_Val : Table_Component_Type) is
begin
Increment_Last;
Table (Table_Index_Type (Last_Val)) := New_Val;
end Append;
--------------------
-- Decrement_Last --
--------------------
procedure Decrement_Last is
begin
Last_Val := Last_Val - 1;
end Decrement_Last;
----------
-- Free --
----------
procedure Free is
procedure free (T : Table_Ptr);
pragma Import (C, free);
begin
free (Table);
Table := null;
Length := 0;
end Free;
--------------------
-- Increment_Last --
--------------------
procedure Increment_Last is
begin
Last_Val := Last_Val + 1;
if Last_Val > Max then
Reallocate;
end if;
end Increment_Last;
----------
-- Init --
----------
procedure Init is
Old_Length : Integer := Length;
begin
Last_Val := Min - 1;
Max := Min + Table_Initial - 1;
Length := Max - Min + 1;
-- If table is same size as before (happens when table is never
-- expanded which is a common case), then simply reuse it. Note
-- that this also means that an explicit Init call right after
-- the implicit one in the package body is harmless.
if Old_Length = Length then
return;
-- Otherwise we can use Reallocate to get a table of the right size.
-- Note that Reallocate works fine to allocate a table of the right
-- initial size when it is first allocated.
else
Reallocate;
end if;
end Init;
----------
-- Last --
----------
function Last return Table_Index_Type is
begin
return Table_Index_Type (Last_Val);
end Last;
----------------
-- Reallocate --
----------------
procedure Reallocate is
function realloc
(memblock : Table_Ptr;
size : size_t)
return Table_Ptr;
pragma Import (C, realloc);
function malloc
(size : size_t)
return Table_Ptr;
pragma Import (C, malloc);
New_Size : size_t;
begin
if Max < Last_Val then
pragma Assert (not Locked);
while Max < Last_Val loop
-- Increase length using the table increment factor, but make
-- sure that we add at least ten elements (this avoids a loop
-- for silly small increment values)
Length := Integer'Max
(Length * (100 + Table_Increment) / 100,
Length + 10);
Max := Min + Length - 1;
end loop;
end if;
New_Size :=
size_t ((Max - Min + 1) *
(Table_Type'Component_Size / Storage_Unit));
if Table = null then
Table := malloc (New_Size);
elsif New_Size > 0 then
Table :=
realloc
(memblock => Table,
size => New_Size);
end if;
if Length /= 0 and then Table = null then
raise Storage_Error;
end if;
end Reallocate;
-------------
-- Release --
-------------
procedure Release is
begin
Length := Last_Val - Integer (Table_Low_Bound) + 1;
Max := Last_Val;
Reallocate;
end Release;
--------------
-- Set_Item --
--------------
procedure Set_Item
(Index : Table_Index_Type;
Item : Table_Component_Type)
is
begin
if Integer (Index) > Max then
Set_Last (Index);
end if;
Table (Index) := Item;
end Set_Item;
--------------
-- Set_Last --
--------------
procedure Set_Last (New_Val : Table_Index_Type) is
begin
if Integer (New_Val) < Last_Val then
Last_Val := Integer (New_Val);
else
Last_Val := Integer (New_Val);
if Last_Val > Max then
Reallocate;
end if;
end if;
end Set_Last;
begin
Init;
end GNAT.Table;

189
gcc/ada/g-table.ads Normal file
View File

@ -0,0 +1,189 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . T A B L E --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Resizable one dimensional array support
-- This package provides an implementation of dynamically resizable one
-- dimensional arrays. The idea is to mimic the normal Ada semantics for
-- arrays as closely as possible with the one additional capability of
-- dynamically modifying the value of the Last attribute.
-- This package provides a facility similar to that of GNAT.Dynamic_Tables,
-- except that this package declares a single instance of the table type,
-- while an instantiation of GNAT.Dynamic_Tables creates a type that can be
-- used to define dynamic instances of the table.
-- Note that this interface should remain synchronized with those in
-- GNAT.Dynamic_Tables and the GNAT compiler source unit Table to keep
-- as much coherency as possible between these three related units.
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive;
Table_Increment : Natural;
package GNAT.Table is
pragma Elaborate_Body (Table);
-- Table_Component_Type and Table_Index_Type specify the type of the
-- array, Table_Low_Bound is the lower bound. Index_type must be an
-- integer type. The effect is roughly to declare:
-- Table : array (Table_Index_Type range Table_Low_Bound .. <>)
-- of Table_Component_Type;
-- Note: since the upper bound can be one less than the lower
-- bound for an empty array, the table index type must be able
-- to cover this range, e.g. if the lower bound is 1, then the
-- Table_Index_Type should be Natural rather than Positive.
-- Table_Component_Type may be any Ada type, except that controlled
-- types are not supported. Note however that default initialization
-- will NOT occur for array components.
-- The Table_Initial values controls the allocation of the table when
-- it is first allocated, either by default, or by an explicit Init call.
-- The Table_Increment value controls the amount of increase, if the
-- table has to be increased in size. The value given is a percentage
-- value (e.g. 100 = increase table size by 100%, i.e. double it).
-- The Last and Set_Last subprograms provide control over the current
-- logical allocation. They are quite efficient, so they can be used
-- freely (expensive reallocation occurs only at major granularity
-- chunks controlled by the allocation parameters).
-- Note: we do not make the table components aliased, since this would
-- restrict the use of table for discriminated types. If it is necessary
-- to take the access of a table element, use Unrestricted_Access.
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained
-- with the maximum possible range bound. This means that the pointer
-- is a thin pointer, which is more efficient. Since subscript checks
-- in any case must be on the logical, rather than physical bounds,
-- safety is not compromised by this approach.
type Table_Ptr is access all Big_Table_Type;
-- The table is actually represented as a pointer to allow reallocation
Table : aliased Table_Ptr := null;
-- The table itself. The lower bound is the value of Low_Bound.
-- Logically the upper bound is the current value of Last (although
-- the actual size of the allocated table may be larger than this).
-- The program may only access and modify Table entries in the range
-- First .. Last.
Locked : Boolean := False;
-- Table expansion is permitted only if this switch is set to False. A
-- client may set Locked to True, in which case any attempt to expand
-- the table will cause an assertion failure. Note that while a table
-- is locked, its address in memory remains fixed and unchanging.
procedure Init;
-- This procedure allocates a new table of size Initial (freeing any
-- previously allocated larger table). It is not necessary to call
-- Init when a table is first instantiated (since the instantiation does
-- the same initialization steps). However, it is harmless to do so, and
-- Init is convenient in reestablishing a table for new use.
function Last return Table_Index_Type;
pragma Inline (Last);
-- Returns the current value of the last used entry in the table, which
-- can then be used as a subscript for Table. Note that the only way to
-- modify Last is to call the Set_Last procedure. Last must always be
-- used to determine the logically last entry.
procedure Release;
-- Storage is allocated in chunks according to the values given in the
-- Initial and Increment parameters. A call to Release releases all
-- storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call.
procedure Free;
-- Free all allocated memory for the table. A call to init is required
-- before any use of this table after calling Free.
First : constant Table_Index_Type := Table_Low_Bound;
-- Export First as synonym for Low_Bound (parallel with use of Last)
procedure Set_Last (New_Val : Table_Index_Type);
pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the
-- table is reallocated to accomodate the new value (i.e. on return
-- the allocated table has an upper bound of at least Last). If Set_Last
-- reduces the size of the table, then logically entries are removed
-- from the table. If Set_Last increases the size of the table, then
-- new entries are logically added to the table.
procedure Increment_Last;
pragma Inline (Increment_Last);
-- Adds 1 to Last (same as Set_Last (Last + 1).
procedure Decrement_Last;
pragma Inline (Decrement_Last);
-- Subtracts 1 from Last (same as Set_Last (Last - 1).
procedure Append (New_Val : Table_Component_Type);
pragma Inline (Append);
-- Equivalent to:
-- x.Increment_Last;
-- x.Table (x.Last) := New_Val;
-- i.e. the table size is increased by one, and the given new item
-- stored in the newly created table element.
procedure Set_Item
(Index : Table_Index_Type;
Item : Table_Component_Type);
pragma Inline (Set_Item);
-- Put Item in the table at position Index. The table is expanded if the
-- current table length is less than Index and in that case Last is set to
-- Index. Item will replace any value already present in the table at this
-- position.
function Allocate (Num : Integer := 1) return Table_Index_Type;
pragma Inline (Allocate);
-- Adds Num to Last, and returns the old value of Last + 1. Note that
-- this function has the possible side effect of reallocating the table.
-- This means that a reference X.Table (X.Allocate) is incorrect, since
-- the call to X.Allocate may modify the results of calling X.Table.
end GNAT.Table;

58
gcc/ada/g-tasloc.adb Normal file
View File

@ -0,0 +1,58 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T A S K _ L O C K --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1997-1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Soft_Links;
-- used for Lock_Task, Unlock_Task
package body GNAT.Task_Lock is
----------
-- Lock --
----------
procedure Lock is
begin
System.Soft_Links.Lock_Task.all;
end Lock;
------------
-- Unlock --
------------
procedure Unlock is
begin
System.Soft_Links.Unlock_Task.all;
end Unlock;
end GNAT.Task_Lock;

93
gcc/ada/g-tasloc.ads Normal file
View File

@ -0,0 +1,93 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T A S K _ L O C K --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Simple task lock and unlock routines
-- A small package containing a task lock and unlock routines for creating
-- a critical region. The lock involved is a global lock, shared by all
-- tasks, and by all calls to these routines, so these routines should be
-- used with care to avoid unnecessary reduction of concurrency.
-- These routines may be used in a non-tasking program, and in that case
-- they have no effect (they do NOT cause the tasking runtime to be loaded).
package GNAT.Task_Lock is
pragma Elaborate_Body (Task_Lock);
procedure Lock;
pragma Inline (Lock);
-- Acquires the global lock, starts the execution of a critical region
-- which no other task can enter until the locking task calls Unlock
procedure Unlock;
pragma Inline (Unlock);
-- Releases the global lock, allowing another task to successfully
-- complete a Lock operation. Terminates the critical region.
-- The recommended protocol for using these two procedures is as
-- follows:
-- Locked_Processing : begin
-- Lock;
-- ...
-- TSL.Unlock;
--
-- exception
-- when others =>
-- Unlock;
-- raise;
-- end Locked_Processing;
-- This ensures that the lock is not left set if an exception is raised
-- explicitly or implicitly during the critical locked region.
-- Note on multiple calls to Lock: It is permissible to call Lock
-- more than once with no intervening Unlock from a single task,
-- and the lock will not be released until the corresponding number
-- of Unlock operations has been performed. For example:
-- GNAT.Task_Lock.Lock; -- acquires lock
-- GNAT.Task_Lock.Lock; -- no effect
-- GNAT.Task_Lock.Lock; -- no effect
-- GNAT.Task_Lock.Unlock; -- no effect
-- GNAT.Task_Lock.Unlock; -- no effect
-- GNAT.Task_Lock.Unlock; -- releases lock
-- However, as previously noted, the Task_Lock facility should only
-- be used for very local locks where the probability of conflict is
-- low, so usually this kind of nesting is not a good idea in any case.
-- In more complex locking situations, it is more appropriate to define
-- an appropriate protected type to provide the required locking.
end GNAT.Task_Lock;

111
gcc/ada/g-thread.adb Normal file
View File

@ -0,0 +1,111 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . T H R E A D S --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1998-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Task_Identification; use Ada.Task_Identification;
with System.Task_Primitives.Operations;
with System.Tasking;
with System.OS_Interface;
with Unchecked_Conversion;
package body GNAT.Threads is
use System;
function To_Addr is new Unchecked_Conversion (Task_Id, Address);
function To_Id is new Unchecked_Conversion (Address, Task_Id);
function To_Id is new Unchecked_Conversion (Address, Tasking.Task_ID);
type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr);
task type Thread
(Stsz : Natural;
Prio : Any_Priority;
Parm : Void_Ptr;
Code : Code_Proc)
is
pragma Priority (Prio);
pragma Storage_Size (Stsz);
end Thread;
task body Thread is
begin
Code.all (To_Addr (Current_Task), Parm);
end Thread;
type Tptr is access Thread;
-------------------
-- Create_Thread --
-------------------
function Create_Thread
(Code : Address;
Parm : Void_Ptr;
Size : Natural;
Prio : Integer) return System.Address
is
TP : Tptr;
function To_CP is new Unchecked_Conversion (Address, Code_Proc);
begin
TP := new Thread (Size, Prio, Parm, To_CP (Code));
return To_Addr (TP'Identity);
end Create_Thread;
--------------------
-- Destroy_Thread --
--------------------
procedure Destroy_Thread (Id : Address) is
Tid : Task_Id := To_Id (Id);
begin
Abort_Task (Tid);
end Destroy_Thread;
----------------
-- Get_Thread --
----------------
procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface;
Thr : Thread_Id;
for Thr use at Thread;
begin
Thr := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread;
end GNAT.Threads;

95
gcc/ada/g-thread.ads Normal file
View File

@ -0,0 +1,95 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . T H R E A D S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1998-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides facilities for creation of foreign threads for
-- use as Ada tasks. In order to execute general Ada code, the run-time
-- system must know about all tasks. This package allows foreign code,
-- e.g. a C program, to create a thread that the Ada run-time knows about.
with System;
package GNAT.Threads is
type Void_Ptr is access all Integer;
function Create_Thread
(Code : System.Address; -- pointer
Parm : Void_Ptr; -- pointer
Size : Natural; -- int
Prio : Integer) -- int
return System.Address;
pragma Export (C, Create_Thread, "__gnat_create_thread");
-- Creates a thread with the given (Size) stack size in bytes, and
-- the given (Prio) priority. The task will execute a call to the
-- procedure whose address is given by Code. This procedure has
-- the prototype
--
-- void thread_code (void *id, void *parm);
--
-- where id is the id of the created task, and parm is the parameter
-- passed to Create_Thread. The called procedure is the body of the
-- code for the task, the task will be automatically terminated when
-- the procedure returns.
--
-- This function returns the Ada Id of the created task that can then be
-- used as a parameter to the procedures below.
--
-- C declaration:
--
-- extern void *__gnat_create_thread
-- (void (*code)(void *, void *), void *parm, int size, int prio);
procedure Destroy_Thread (Id : System.Address);
pragma Export (C, Destroy_Thread, "__gnat_destroy_thread");
-- This procedure may be used to prematurely abort the created thread.
-- The value Id is the value that was passed to the thread code procedure
-- at activation time.
--
-- C declaration:
--
-- extern void __gnat_destroy_thread (void *id);
procedure Get_Thread (Id : System.Address; Thread : System.Address);
pragma Export (C, Get_Thread, "__gnat_get_thread");
-- This procedure is used to retrieve the thread id of a given task.
-- The value Id is the value that was passed to the thread code procedure
-- at activation time.
-- Thread is a pointer to a thread id that will be updated by this
-- procedure.
--
-- C declaration:
--
-- extern void __gnat_get_thread (void *id, pthread_t *thread);
end GNAT.Threads;

53
gcc/ada/g-traceb.adb Normal file
View File

@ -0,0 +1,53 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T R A C E B A C K --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1999-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Run-time non-symbolic traceback support
with System.Traceback;
package body GNAT.Traceback is
----------------
-- Call_Chain --
----------------
procedure Call_Chain
(Traceback : out Tracebacks_Array;
Len : out Natural)
is
begin
System.Traceback.Call_Chain (Traceback'Address, Traceback'Length, Len);
end Call_Chain;
end GNAT.Traceback;

90
gcc/ada/g-traceb.ads Normal file
View File

@ -0,0 +1,90 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T R A C E B A C K --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $
-- --
-- Copyright (C) 1999-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Run-time non-symbolic traceback support
-- This package provides a method for generating a traceback of the
-- current execution location. The traceback shows the locations of
-- calls in the call chain, up to either the top or a designated
-- number of levels.
-- The traceback information is in the form of absolute code locations.
-- These code locations may be converted to corresponding source locations
-- using the external addr2line utility, or from within GDB.
-- To analyze the code locations later using addr2line or gdb, the necessary
-- units must be compiled with the debugging switch -g in the usual manner.
-- Note that it is not necesary to compile with -g to use Call_Chain. In
-- other words, the following sequence of steps can be used:
-- Compile without -g
-- Run the program, and call Call_Chain
-- Recompile with -g
-- Use addr2line to interpret the absolute call locations
-- This capability is currently supported on the following targets:
-- All x86 ports
-- AiX PowerPC
-- HP-UX
-- Irix
-- Solaris sparc
-- Tru64
-- VxWorks PowerPC
-- VxWorks Alpha
with System;
package GNAT.Traceback is
pragma Elaborate_Body;
subtype Code_Loc is System.Address;
-- Code location used in building tracebacks
type Tracebacks_Array is array (Positive range <>) of Code_Loc;
-- Traceback array used to hold a generated traceback list.
----------------
-- Call_Chain --
----------------
procedure Call_Chain (Traceback : out Tracebacks_Array; Len : out Natural);
-- Store up to Traceback'Length tracebacks corresponding to the current
-- call chain. The first entry stored corresponds to the deepest level
-- of subprogram calls. Len shows the number of traceback entries stored.
-- It will be equal to Traceback'Length unless the entire traceback is
-- shorter, in which case positions in Traceback past the Len position
-- are undefined on return.
end GNAT.Traceback;

87
gcc/ada/g-trasym.adb Normal file
View File

@ -0,0 +1,87 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T R A C E B A C K . S Y M B O L I C --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1999 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Run-time symbolic traceback support
with System.Soft_Links;
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
package body GNAT.Traceback.Symbolic is
pragma Linker_Options ("-laddr2line");
pragma Linker_Options ("-lbfd");
pragma Linker_Options ("-liberty");
package TSL renames System.Soft_Links;
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
procedure convert_addresses
(addrs : System.Address;
n_addr : Integer;
buf : System.Address;
len : System.Address);
pragma Import (C, convert_addresses, "convert_addresses");
-- This is the procedure version of the Ada aware addr2line that will
-- use argv[0] as the executable containing the debug information.
-- This procedure is provided by libaddr2line on targets that support
-- it. A dummy version is in a-adaint.c for other targets so that build
-- of shared libraries doesn't generate unresolved symbols.
--
-- Note that this procedure is *not* thread-safe.
Res : String (1 .. 256 * Traceback'Length);
Len : Integer;
begin
if Traceback'Length > 0 then
TSL.Lock_Task.all;
convert_addresses
(Traceback'Address, Traceback'Length, Res (1)'Address, Len'Address);
TSL.Unlock_Task.all;
return Res (1 .. Len);
else
return "";
end if;
end Symbolic_Traceback;
function Symbolic_Traceback (E : Exception_Occurrence) return String is
begin
return Symbolic_Traceback (Tracebacks (E));
end Symbolic_Traceback;
end GNAT.Traceback.Symbolic;

60
gcc/ada/g-trasym.ads Normal file
View File

@ -0,0 +1,60 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . T R A C E B A C K . S Y M B O L I C --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1999-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Run-time symbolic traceback support
-- Note: this is only available on selected targets. Currently it is
-- supported on Sparc/Solaris, Linux, Windows NT, HP-UX, IRIX and Tru64.
-- The routines provided in this package assume that your application has
-- been compiled with debugging information turned on, since this information
-- is used to build a symbolic traceback.
with Ada.Exceptions; use Ada.Exceptions;
package GNAT.Traceback.Symbolic is
pragma Elaborate_Body (Traceback.Symbolic);
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String;
-- Build a string containing a symbolic traceback of the given call chain.
function Symbolic_Traceback (E : Exception_Occurrence) return String;
-- Build a string containing a symbolic traceback of the given exception
-- occurrence.
end GNAT.Traceback.Symbolic;

62
gcc/ada/get_targ.adb Normal file
View File

@ -0,0 +1,62 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E T _ T A R G --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $ --
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body Get_Targ is
----------------------
-- Digits_From_Size --
----------------------
function Digits_From_Size (Size : Pos) return Pos is
begin
if Size = 32 then return 6;
elsif Size = 48 then return 9;
elsif Size = 64 then return 15;
elsif Size = 96 then return 18;
elsif Size = 128 then return 18;
else
raise Program_Error;
end if;
end Digits_From_Size;
---------------------
-- Width_From_Size --
---------------------
function Width_From_Size (Size : Pos) return Pos is
begin
if Size = 8 then return 4;
elsif Size = 16 then return 6;
elsif Size = 32 then return 11;
elsif Size = 64 then return 21;
else
raise Program_Error;
end if;
end Width_From_Size;
end Get_Targ;

107
gcc/ada/get_targ.ads Normal file
View File

@ -0,0 +1,107 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G E T _ T A R G --
-- --
-- S p e c --
-- --
-- $Revision: 1.15 $
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package provides an Import to the C functions which provide
-- values related to types on the target system. It is only needed for
-- exp_dbug and the elaboration of ttypes.
-- NOTE: Any changes in this package must be reflected in jgettarg.ads!
-- Note that all these values return sizes of C types with corresponding
-- names. This allows GNAT to define the corresponding Ada types to have
-- the same representation. There is one exception to this: the
-- Wide_Character_Type uses twice the size of a C char, instead of the
-- size of wchar_t.
with Types; use Types;
package Get_Targ is
pragma Preelaborate (Get_Targ);
function Get_Bits_Per_Unit return Pos;
pragma Import (C, Get_Bits_Per_Unit, "get_target_bits_per_unit");
function Get_Bits_Per_Word return Pos;
pragma Import (C, Get_Bits_Per_Word, "get_target_bits_per_word");
function Get_Char_Size return Pos; -- Standard.Character'Size
pragma Import (C, Get_Char_Size, "get_target_char_size");
function Get_Wchar_T_Size return Pos; -- Interfaces.C.wchar_t'Size
pragma Import (C, Get_Wchar_T_Size, "get_target_wchar_t_size");
function Get_Short_Size return Pos; -- Standard.Short_Integer'Size
pragma Import (C, Get_Short_Size, "get_target_short_size");
function Get_Int_Size return Pos; -- Standard.Integer'Size
pragma Import (C, Get_Int_Size, "get_target_int_size");
function Get_Long_Size return Pos; -- Standard.Long_Integer'Size
pragma Import (C, Get_Long_Size, "get_target_long_size");
function Get_Long_Long_Size return Pos; -- Standard.Long_Long_Integer'Size
pragma Import (C, Get_Long_Long_Size, "get_target_long_long_size");
function Get_Float_Size return Pos; -- Standard.Float'Size
pragma Import (C, Get_Float_Size, "get_target_float_size");
function Get_Double_Size return Pos; -- Standard.Long_Float'Size
pragma Import (C, Get_Double_Size, "get_target_double_size");
function Get_Long_Double_Size return Pos; -- Standard.Long_Long_Float'Size
pragma Import (C, Get_Long_Double_Size, "get_target_long_double_size");
function Get_Pointer_Size return Pos; -- System.Address'Size
pragma Import (C, Get_Pointer_Size, "get_target_pointer_size");
function Get_Maximum_Alignment return Pos;
pragma Import (C, Get_Maximum_Alignment, "get_target_maximum_alignment");
function Get_No_Dollar_In_Label return Boolean;
pragma Import (C, Get_No_Dollar_In_Label, "get_target_no_dollar_in_label");
function Get_Float_Words_BE return Nat;
pragma Import (C, Get_Float_Words_BE, "get_float_words_be");
function Get_Words_BE return Nat;
pragma Import (C, Get_Words_BE, "get_words_be");
function Get_Bytes_BE return Nat;
pragma Import (C, Get_Bytes_BE, "get_bytes_be");
function Get_Bits_BE return Nat;
pragma Import (C, Get_Bits_BE, "get_bits_be");
function Get_Strict_Alignment return Nat;
pragma Import (C, Get_Strict_Alignment, "get_strict_alignment");
function Width_From_Size (Size : Pos) return Pos;
function Digits_From_Size (Size : Pos) return Pos;
-- Calculate values for 'Width or 'Digits from 'Size
end Get_Targ;

783
gcc/ada/gigi.h Normal file
View File

@ -0,0 +1,783 @@
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* G I G I *
* *
* C Header File *
* *
* $Revision: 1.1 $
* *
* 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- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
* MA 02111-1307, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
* *
****************************************************************************/
/* Declare all functions and types used by gigi. */
/* Decode all the language specific options that cannot be decoded by GCC. The
option decoding phase of GCC calls this routine on the flags that it cannot
decode. This routine returns 1 if it is successful, otherwise it
returns 0. */
extern int gnat_decode_option PARAMS ((int, char **));
/* Perform all initialization steps for option processing. */
extern void gnat_init_options PARAMS ((void));
/* Perform all the initialization steps that are language-specific. */
extern void gnat_init PARAMS ((void));
/* See if DECL has an RTL that is indirect via a pseudo-register or a
memory location and replace it with an indirect reference if so.
This improves the debugger's ability to display the value. */
extern void adjust_decl_rtl PARAMS ((tree));
/* Record the current code position in GNAT_NODE. */
extern void record_code_position PARAMS ((Node_Id));
/* Insert the code for GNAT_NODE at the position saved for that node. */
extern void insert_code_for PARAMS ((Node_Id));
/* Routine called by gcc for emitting a stack check. GNU_EXPR is the
expression that contains the last address on the stack to check. */
extern tree emit_stack_check PARAMS ((tree));
/* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
extern tree make_transform_expr PARAMS ((Node_Id));
/* Update the setjmp buffer BUF with the current stack pointer. We assume
here that a __builtin_setjmp was done to BUF. */
extern void update_setjmp_buf PARAMS ((tree));
/* Get the alias set corresponding to a type or expression. */
extern HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree));
/* GNU_TYPE is a type. Determine if it should be passed by reference by
default. */
extern int default_pass_by_ref PARAMS ((tree));
/* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
it should be passed by reference. */
extern int must_pass_by_ref PARAMS ((tree));
/* Elaboration routines for the front end */
extern void elab_all_gnat PARAMS ((void));
/* Emit a label UNITNAME_LABEL and specify that it is part of source
file FILENAME. If this is being written for SGI's Workshop
debugger, and we are writing Dwarf2 debugging information, add
additional debug info. */
extern void emit_unit_label PARAMS ((char *, char *));
/* Initialize DUMMY_NODE_TABLE. */
extern void init_dummy_type PARAMS ((void));
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
entity, this routine returns the equivalent GCC tree for that entity
(an ..._DECL node) and associates the ..._DECL node with the input GNAT
defining identifier.
If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
initial value (in GCC tree form). This is optional for variables.
For renamed entities, GNU_EXPR gives the object being renamed.
DEFINITION is nonzero if this call is intended for a definition. This is
used for separate compilation where it necessary to know whether an
external declaration or a definition should be created if the GCC equivalent
was not created previously. The value of 1 is normally used for a non-zero
DEFINITION, but a value of 2 is used in special circumstances, defined in
the code. */
extern tree gnat_to_gnu_entity PARAMS ((Entity_Id, tree, int));
/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
GCC type corresponding to that entity. GNAT_ENTITY is assumed to
refer to an Ada type. */
extern tree gnat_to_gnu_type PARAMS ((Entity_Id));
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
extern void elaborate_entity PARAMS ((Entity_Id));
/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
any entities on its entity chain similarly. */
extern void mark_out_of_scope PARAMS ((Entity_Id));
/* Make a dummy type corresponding to GNAT_TYPE. */
extern tree make_dummy_type PARAMS ((Entity_Id));
/* Get the unpadded version of a GNAT type. */
extern tree get_unpadded_type PARAMS ((Entity_Id));
/* Called when we need to protect a variable object using a save_expr. */
extern tree maybe_variable PARAMS ((tree, Node_Id));
/* Create a record type that contains a field of TYPE with a starting bit
position so that it is aligned to ALIGN bits. */
/* Create a record type that contains a field of TYPE with a starting bit
position so that it is aligned to ALIGN bits and is SIZE bytes long. */
extern tree make_aligning_type PARAMS ((tree, int, tree));
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
extern tree choices_to_gnu PARAMS ((tree, Node_Id));
/* Given a type T, a FIELD_DECL F, and a replacement value R,
return a new type with all size expressions that contain F
updated by replacing F with R. This is identical to GCC's
substitute_in_type except that it knows about TYPE_INDEX_TYPE. */
extern tree gnat_substitute_in_type PARAMS ((tree, tree, tree));
/* Return the "RM size" of GNU_TYPE. This is the actual number of bits
needed to represent the object. */
extern tree rm_size PARAMS ((tree));
/* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
string, return a new IDENTIFIER_NODE that is the concatenation of
the name in GNU_ID and SUFFIX. */
extern tree concat_id_with_name PARAMS ((tree, const char *));
/* Return the name to be used for GNAT_ENTITY. If a type, create a
fully-qualified name, possibly with type information encoding.
Otherwise, return the name. */
extern tree get_entity_name PARAMS ((Entity_Id));
/* Return a name for GNAT_ENTITY concatenated with two underscores and
SUFFIX. */
extern tree create_concat_name PARAMS ((Entity_Id, const char *));
/* Flag indicating whether file names are discarded in exception messages */
extern int discard_file_names;
/* If true, then gigi is being called on an analyzed but unexpanded
tree, and the only purpose of the call is to properly annotate
types with representation information */
extern int type_annotate_only;
/* Current file name without path */
extern const char *ref_filename;
/* List of TREE_LIST nodes representing a block stack. TREE_VALUE
of each gives the variable used for the setjmp buffer in the current
block, if any. */
extern tree gnu_block_stack;
/* For most front-ends, this is the parser for the language. For us, we
process the GNAT tree. */
extern int yyparse PARAMS ((void));
/* This is the main program of the back-end. It sets up all the table
structures and then generates code. */
extern void gigi PARAMS ((Node_Id, int, int, struct Node *,
Node_Id *, Node_Id *,
struct Elist_Header *,
struct Elmt_Item *,
struct String_Entry *,
Char_Code *,
struct List_Header *,
Int, char *,
Entity_Id, Entity_Id, Entity_Id,
Int));
/* This function is the driver of the GNAT to GCC tree transformation process.
GNAT_NODE is the root of some gnat tree. It generates code for that
part of the tree. */
extern void gnat_to_code PARAMS ((Node_Id));
/* GNAT_NODE is the root of some GNAT tree. Return the root of the
GCC tree corresponding to that GNAT tree. Normally, no code is generated;
we just return an equivalent tree which is used elsewhere to generate
code. */
extern tree gnat_to_gnu PARAMS ((Node_Id));
/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
a separate Freeze node exists, delay the bulk of the processing. Otherwise
make a GCC type for GNAT_ENTITY and set up the correspondance. */
extern void process_type PARAMS ((Entity_Id));
/* Determine the input_filename and the lineno from the source location
(Sloc) of GNAT_NODE node. Set the global variable input_filename and
lineno. If WRITE_NOTE_P is true, emit a line number note. */
extern void set_lineno PARAMS ((Node_Id, int));
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
"&" substitution. */
extern void post_error PARAMS ((const char *, Node_Id));
/* Similar, but NODE is the node at which to post the error and ENT
is the node to use for the "&" substitution. */
extern void post_error_ne PARAMS ((const char *, Node_Id, Entity_Id));
/* Similar, but NODE is the node at which to post the error, ENT is the node
to use for the "&" substitution, and N is the number to use for the ^. */
extern void post_error_ne_num PARAMS ((const char *, Node_Id, Entity_Id,
int));
/* Similar to post_error_ne_num, but T is a GCC tree representing the number
to write. If the tree represents a constant that fits within a
host integer, the text inside curly brackets in MSG will be output
(presumably including a '^'). Otherwise that text will not be output
and the text inside square brackets will be output instead. */
extern void post_error_ne_tree PARAMS ((const char *, Node_Id, Entity_Id,
tree));
/* Similar to post_error_ne_tree, except that NUM is a second
integer to write in the message. */
extern void post_error_ne_tree_2 PARAMS ((const char *, Node_Id, Entity_Id,
tree, int));
/* Set the node for a second '&' in the error message. */
extern void set_second_error_entity PARAMS ((Entity_Id));
/* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially
since it doesn't make any sense to put them in a SAVE_EXPR. */
extern tree make_save_expr PARAMS ((tree));
/* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
as the relevant node that provides the location info for the error.
The single parameter CODE is an integer code that is included in the
additional error message generated. */
extern void gigi_abort PARAMS ((int)) ATTRIBUTE_NORETURN;
/* Initialize the table that maps GNAT codes to GCC codes for simple
binary and unary operations. */
extern void init_code_table PARAMS ((void));
/* Current node being treated, in case gigi_abort or Check_Elaboration_Code
called. */
extern Node_Id error_gnat_node;
/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
how to handle our new nodes and we take an extra argument that says
whether to force evaluation of everything. */
extern tree gnat_stabilize_reference PARAMS ((tree, int));
/* Highest number in the front-end node table. */
extern int max_gnat_nodes;
/* If nonzero, pretend we are allocating at global level. */
extern int force_global;
/* Standard data type sizes. Most of these are not used. */
#ifndef CHAR_TYPE_SIZE
#define CHAR_TYPE_SIZE BITS_PER_UNIT
#endif
#ifndef SHORT_TYPE_SIZE
#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
#endif
#ifndef INT_TYPE_SIZE
#define INT_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef LONG_TYPE_SIZE
#define LONG_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef LONG_LONG_TYPE_SIZE
#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
#ifndef FLOAT_TYPE_SIZE
#define FLOAT_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef DOUBLE_TYPE_SIZE
#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
#ifndef LONG_DOUBLE_TYPE_SIZE
#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
/* The choice of SIZE_TYPE here is very problematic. We need a signed
type whose bit width is Pmode. Assume "long" is such a type here. */
#undef SIZE_TYPE
#define SIZE_TYPE "long int"
/* Data structures used to represent attributes. */
enum attr_type {ATTR_MACHINE_ATTRIBUTE, ATTR_LINK_ALIAS,
ATTR_LINK_SECTION, ATTR_WEAK_EXTERNAL};
struct attrib
{
struct attrib *next;
enum attr_type type;
tree name;
tree arg;
Node_Id error_point;
};
/* Define the entries in the standard data array. */
enum standard_datatypes
{
/* Various standard data types and nodes. */
ADT_longest_float_type,
ADT_void_type_decl,
/* The type of an exception. */
ADT_except_type,
/* Type declaration node <==> typedef void *T */
ADT_ptr_void_type,
/* Function type declaration -- void T() */
ADT_void_ftype,
/* Type declaration node <==> typedef void *T() */
ADT_ptr_void_ftype,
/* A function declaration node for a run-time function for allocating memory.
Ada allocators cause calls to this function to be generated. */
ADT_malloc_decl,
/* Likewise for freeing memory. */
ADT_free_decl,
/* Types and decls used by our temporary exception mechanism. See
init_gigi_decls for details. */
ADT_jmpbuf_type,
ADT_jmpbuf_ptr_type,
ADT_get_jmpbuf_decl,
ADT_set_jmpbuf_decl,
ADT_get_excptr_decl,
ADT_setjmp_decl,
ADT_longjmp_decl,
ADT_raise_nodefer_decl,
ADT_raise_constraint_error_decl,
ADT_raise_program_error_decl,
ADT_raise_storage_error_decl,
ADT_LAST};
extern tree gnat_std_decls[(int) ADT_LAST];
#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type]
#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl]
#define except_type_node gnat_std_decls[(int) ADT_except_type]
#define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type]
#define void_ftype gnat_std_decls[(int) ADT_void_ftype]
#define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype]
#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
#define free_decl gnat_std_decls[(int) ADT_free_decl]
#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
#define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl]
#define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl]
#define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl]
#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl]
#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl]
#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl]
#define raise_constraint_error_decl \
gnat_std_decls[(int) ADT_raise_constraint_error_decl]
#define raise_program_error_decl \
gnat_std_decls[(int) ADT_raise_program_error_decl]
#define raise_storage_error_decl \
gnat_std_decls[(int) ADT_raise_storage_error_decl]
/* Routines expected by the gcc back-end. They must have exactly the same
prototype and names as below. */
/* Returns non-zero if we are currently in the global binding level */
extern int global_bindings_p PARAMS ((void));
/* Returns the list of declarations in the current level. Note that this list
is in reverse order (it has to be so for back-end compatibility). */
extern tree getdecls PARAMS ((void));
/* Nonzero if the current level needs to have a BLOCK made. */
extern int kept_level_p PARAMS ((void));
/* Enter a new binding level. The input parameter is ignored, but has to be
specified for back-end compatibility. */
extern void pushlevel PARAMS ((int));
/* Exit a binding level.
Pop the level off, and restore the state of the identifier-decl mappings
that were in effect when this level was entered.
If KEEP is nonzero, this level had explicit declarations, so
and create a "block" (a BLOCK node) for the level
to record its declarations and subblocks for symbol table output.
If FUNCTIONBODY is nonzero, this level is the body of a function,
so create a block as if KEEP were set and also clear out all
label names.
If REVERSE is nonzero, reverse the order of decls before putting
them into the BLOCK. */
extern tree poplevel PARAMS ((int,int, int));
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
to handle the BLOCK node inside the BIND_EXPR. */
extern void insert_block PARAMS ((tree));
/* Set the BLOCK node for the innermost scope
(the one we are currently in). */
extern void set_block PARAMS ((tree));
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
extern tree pushdecl PARAMS ((tree));
/* Create the predefined scalar types such as `integer_type_node' needed
in the gcc back-end and initialize the global binding level. */
extern void init_decl_processing PARAMS ((void));
extern void init_gigi_decls PARAMS ((tree, tree));
/* Return an integer type with the number of bits of precision given by
PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
it is a signed type. */
extern tree type_for_size PARAMS ((unsigned, int));
/* Return a data type that has machine mode MODE. UNSIGNEDP selects
an unsigned type; otherwise a signed type is returned. */
extern tree type_for_mode PARAMS ((enum machine_mode, int));
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
extern tree unsigned_type PARAMS ((tree));
/* Return the signed version of a TYPE_NODE, a scalar type. */
extern tree signed_type PARAMS ((tree));
/* Return a type the same as TYPE except unsigned or signed according to
UNSIGNEDP. */
extern tree signed_or_unsigned_type PARAMS ((int, tree));
/* This routine is called in tree.c to print an error message for invalid use
of an incomplete type. */
extern void incomplete_type_error PARAMS ((tree, tree));
/* This function is called indirectly from toplev.c to handle incomplete
declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
compile_file in toplev.c makes an indirect call through the function pointer
incomplete_decl_finalize_hook which is initialized to this routine in
init_decl_processing. */
extern void finish_incomplete_decl PARAMS ((tree));
/* Create an expression whose value is that of EXPR,
converted to type TYPE. The TREE_TYPE of the value
is always TYPE. This function implements all reasonable
conversions; callers should filter out those that are
not permitted by the language being compiled. */
extern tree convert PARAMS ((tree, tree));
/* Routines created solely for the tree translator's sake. Their prototypes
can be changed as desired. */
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
GNU_DECL is the GCC tree which is to be associated with
GNAT_ENTITY. Such gnu tree node is always an ..._DECL node.
If NO_CHECK is nonzero, the latter check is suppressed.
If GNU_DECL is zero, a previous association is to be reset. */
extern void save_gnu_tree PARAMS ((Entity_Id, tree, int));
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
Return the ..._DECL node that was associated with it. If there is no tree
node associated with GNAT_ENTITY, abort. */
extern tree get_gnu_tree PARAMS ((Entity_Id));
/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
extern int present_gnu_tree PARAMS ((Entity_Id));
/* Initialize tables for above routines. */
extern void init_gnat_to_gnu PARAMS ((void));
/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
nodes (FIELDLIST), finish constructing the record or union type.
If HAS_REP is nonzero, this record has a rep clause; don't call
layout_type but merely set the size and alignment ourselves.
If DEFER_DEBUG is nonzero, do not call the debugging routines
on this type; it will be done later. */
extern void finish_record_type PARAMS ((tree, tree, int, int));
/* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
subprogram. If it is void_type_node, then we are dealing with a procedure,
otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
copy-in/copy-out list to be stored into TYPE_CI_CO_LIST.
RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
object. RETURNS_BY_REF is nonzero if the function returns by reference.
RETURNS_WITH_DSP is nonzero if the function is to return with a
depressed stack pointer. */
extern tree create_subprog_type PARAMS ((tree, tree, tree, int, int,
int));
/* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type PARAMS ((tree));
/* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
TYPE_INDEX_TYPE is INDEX. */
extern tree create_index_type PARAMS ((tree, tree, tree));
/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
string) and TYPE is a ..._TYPE node giving its data type.
ARTIFICIAL_P is nonzero if this is a declaration that was generated
by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
information about this type. */
extern tree create_type_decl PARAMS ((tree, tree, struct attrib *,
int, int));
/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
ASM_NAME is its assembler name (if provided). TYPE is
its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an
optional initial expression; NULL_TREE if none.
CONST_FLAG is nonzero if this variable is constant.
PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
the current compilation unit. This flag should be set when processing the
variable definitions in a package specification. EXTERN_FLAG is nonzero
when processing an external variable declaration (as opposed to a
definition: no storage is to be allocated for the variable here).
STATIC_FLAG is only relevant when not at top level. In that case
it indicates whether to always allocate storage to the variable. */
extern tree create_var_decl PARAMS ((tree, tree, tree, tree, int,
int, int, int,
struct attrib *));
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes PARAMS ((tree, struct attrib *));
/* Obtain any pending elaborations and clear the old list. */
extern tree get_pending_elaborations PARAMS ((void));
/* Return nonzero if there are pending elaborations. */
extern int pending_elaborations_p PARAMS ((void));
/* Save a copy of the current pending elaboration list and make a new
one. */
extern void push_pending_elaborations PARAMS ((void));
/* Pop the stack of pending elaborations. */
extern void pop_pending_elaborations PARAMS ((void));
/* Return the current position in pending_elaborations so we can insert
elaborations after that point. */
extern tree get_elaboration_location PARAMS ((void));
/* Insert the current elaborations after ELAB, which is in some elaboration
list. */
extern void insert_elaboration_list PARAMS ((tree));
/* Add some pending elaborations to the current list. */
extern void add_pending_elaborations PARAMS ((tree, tree));
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
this field is in a record type with a "pragma pack". If SIZE is nonzero
it is the specified size for this field. If POS is nonzero, it is the bit
position. If ADDRESSABLE is nonzero, it means we are allowed to take
the address of this field for aliasing purposes. */
extern tree create_field_decl PARAMS ((tree, tree, tree, int,
tree, tree, int));
/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
PARAM_TYPE is its type. READONLY is nonzero if the parameter is
readonly (either an IN parameter or an address of a pass-by-ref
parameter). */
extern tree create_param_decl PARAMS ((tree, tree, int));
/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
PARM_DECL nodes chained through the TREE_CHAIN field).
INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
fields in the FUNCTION_DECL. */
extern tree create_subprog_decl PARAMS ((tree, tree, tree, tree, int,
int, int, struct attrib *));
/* Returns a LABEL_DECL node for LABEL_NAME. */
extern tree create_label_decl PARAMS ((tree));
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */
extern void begin_subprog_body PARAMS ((tree));
/* Finish the definition of the current subprogram and compile it all the way
to assembler language output. */
extern void end_subprog_body PARAMS ((void));
/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
Return a constructor for the template. */
extern tree build_template PARAMS ((tree, tree, tree));
/* Build a VMS descriptor from a Mechanism_Type, which must specify
a descriptor type, and the GCC type of an object. Each FIELD_DECL
in the type contains in its DECL_INITIAL the expression to use when
a constructor is made for the type. GNAT_ENTITY is a gnat node used
to print out an error message if the mechanism cannot be applied to
an object of that type and also for the name. */
extern tree build_vms_descriptor PARAMS ((tree, Mechanism_Type,
Entity_Id));
/* Build a type to be used to represent an aliased object whose nominal
type is an unconstrained array. This consists of a RECORD_TYPE containing
a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
is used to represent an arbitrary unconstrained object. Use NAME
as the name of the record. */
extern tree build_unc_object_type PARAMS ((tree, tree, tree));
/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
the normal case this is just two adjustments, but we have more to do
if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
extern void update_pointer_to PARAMS ((tree, tree));
/* EXP is an expression for the size of an object. If this size contains
discriminant references, replace them with the maximum (if MAX_P) or
minimum (if ! MAX_P) possible value of the discriminant. */
extern tree max_size PARAMS ((tree, int));
/* Remove all conversions that are done in EXP. This includes converting
from a padded type or converting to a left-justified modular type. */
extern tree remove_conversions PARAMS ((tree));
/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
likewise return an expression pointing to the underlying array. */
extern tree maybe_unconstrained_array PARAMS ((tree));
/* Return an expression that does an unchecked converstion of EXPR to TYPE. */
extern tree unchecked_convert PARAMS ((tree, tree));
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
This preparation consists of taking the ordinary
representation of an expression expr and producing a valid tree
boolean expression describing whether expr is nonzero. We could
simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
but we optimize comparisons, &&, ||, and !.
The resulting type should always be the same as the input type.
This function is simpler than the corresponding C version since
the only possible operands will be things of Boolean type. */
extern tree truthvalue_conversion PARAMS((tree));
/* Return the base type of TYPE. */
extern tree get_base_type PARAMS((tree));
/* Likewise, but only return types known at Ada source. */
extern tree get_ada_base_type PARAMS((tree));
/* EXP is a GCC tree representing an address. See if we can find how
strictly the object at that address is aligned. Return that alignment
strictly the object at that address is aligned. Return that alignment
in bits. If we don't know anything about the alignment, return 0. */
extern unsigned int known_alignment PARAMS((tree));
/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
desired for the result. Usually the operation is to be performed
in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
in which case the type to be used will be derived from the operands. */
extern tree build_binary_op PARAMS((enum tree_code, tree, tree, tree));
/* Similar, but make unary operation. */
extern tree build_unary_op PARAMS((enum tree_code, tree, tree));
/* Similar, but for COND_EXPR. */
extern tree build_cond_expr PARAMS((tree, tree, tree, tree));
/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
the CALL_EXPR. */
extern tree build_call_1_expr PARAMS((tree, tree));
/* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return
the CALL_EXPR. */
extern tree build_call_2_expr PARAMS((tree, tree, tree));
/* Likewise to call FUNDECL with no arguments. */
extern tree build_call_0_expr PARAMS((tree));
/* Call a function FCN that raises an exception and pass the line
number and file name, if requested. */
extern tree build_call_raise PARAMS((tree));
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
extern tree build_constructor PARAMS((tree, tree));
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
for the field, or both. */
extern tree build_component_ref PARAMS((tree, tree, tree));
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
genrate an allocator.
GNU_SIZE is the size of the object and ALIGN is the alignment.
GNAT_PROC, if present is a procedure to call and GNAT_POOL is the
storage pool to use. If not preset, malloc and free will be used. */
extern tree build_call_alloc_dealloc PARAMS((tree, tree, int, Entity_Id,
Entity_Id));
/* Build a GCC tree to correspond to allocating an object of TYPE whose
initial value if INIT, if INIT is nonzero. Convert the expression to
RESULT_TYPE, which must be some type of pointer. Return the tree.
GNAT_PROC and GNAT_POOL optionally give the procedure to call and
the storage pool to use. */
extern tree build_allocator PARAMS((tree, tree, tree, Entity_Id,
Entity_Id));
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
extern tree fill_vms_descriptor PARAMS((tree, Entity_Id));
/* Indicate that we need to make the address of EXPR_NODE and it therefore
should not be allocated in a register. Return 1 if successful. */
extern int mark_addressable PARAMS((tree));
/* These functions return the basic data type sizes and related parameters
about the target machine. */
extern Pos get_target_bits_per_unit PARAMS ((void));
extern Pos get_target_bits_per_word PARAMS ((void));
extern Pos get_target_char_size PARAMS ((void));
extern Pos get_target_wchar_t_size PARAMS ((void));
extern Pos get_target_short_size PARAMS ((void));
extern Pos get_target_int_size PARAMS ((void));
extern Pos get_target_long_size PARAMS ((void));
extern Pos get_target_long_long_size PARAMS ((void));
extern Pos get_target_float_size PARAMS ((void));
extern Pos get_target_double_size PARAMS ((void));
extern Pos get_target_long_double_size PARAMS ((void));
extern Pos get_target_pointer_size PARAMS ((void));
extern Pos get_target_maximum_alignment PARAMS ((void));
extern Boolean get_target_no_dollar_in_label PARAMS ((void));
extern Nat get_float_words_be PARAMS ((void));
extern Nat get_words_be PARAMS ((void));
extern Nat get_bytes_be PARAMS ((void));
extern Nat get_bits_be PARAMS ((void));
extern Nat get_strict_alignment PARAMS ((void));

216
gcc/ada/gmem.c Normal file
View File

@ -0,0 +1,216 @@
/****************************************************************************
* *
* GNATMEM COMPONENTS *
* *
* G M E M *
* *
* $Revision: 1.1 $
* *
* C Implementation File *
* *
* Copyright (C) 2000-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- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
* MA 02111-1307, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
* *
****************************************************************************/
/* This unit reads the allocation tracking log produced by augmented
__gnat_malloc and __gnat_free procedures (see file a-raise.c) and
provides GNATMEM tool with gdb-compliant output. The output is
processed by GNATMEM to detect dynamic memory allocation errors.
See GNATMEM section in GNAT User's Guide for more information.
NOTE: This capability is currently supported on the following targets:
DEC Unix
SGI Irix
Linux x86
Solaris (sparc and x86) (*)
Windows 98/95/NT (x86)
(*) on these targets, the compilation must be done with -funwind-tables to
be able to build the stack backtrace. */
#ifdef __alpha_vxworks
#include "vxWorks.h"
#endif
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#else
#include "config.h"
#include "system.h"
#endif
#include "adaint.h"
static FILE *gmemfile;
/* tb_len is the number of call level supported by this module */
#define TB_LEN 200
static char *tracebk [TB_LEN];
static int cur_tb_len, cur_tb_pos;
extern void convert_addresses PARAMS ((char *[], int, void *,
int *));
static void gmem_read_backtrace PARAMS ((void));
static char *spc2nul PARAMS ((char *));
extern int __gnat_gmem_initialize PARAMS ((char *));
extern void __gnat_gmem_a2l_initialize PARAMS ((char *));
extern void __gnat_gmem_read_next PARAMS ((char *));
extern void __gnat_gmem_read_bt_frame PARAMS ((char *));
/* Reads backtrace information from gmemfile placing them in tracebk
array. cur_tb_len is the size of this array. */
static void
gmem_read_backtrace ()
{
fread (&cur_tb_len, sizeof (int), 1, gmemfile);
fread (tracebk, sizeof (char *), cur_tb_len, gmemfile);
cur_tb_pos = 0;
}
/* Initialize gmem feature from the dumpname file. Return 1 if the
dumpname has been generated by GMEM (instrumented malloc/free) and 0 if not
(i.e. probably a GDB generated file). */
int
__gnat_gmem_initialize (dumpname)
char *dumpname;
{
char header[10];
gmemfile = fopen (dumpname, "rb");
fread (header, 10, 1, gmemfile);
/* Check for GMEM magic-tag. */
if (memcmp (header, "GMEM DUMP\n", 10))
{
fclose (gmemfile);
return 0;
}
return 1;
}
/* Initialize addr2line library */
void
__gnat_gmem_a2l_initialize (exename)
char *exename;
{
extern char **gnat_argv;
char s [100];
int l;
gnat_argv [0] = exename;
convert_addresses (tracebk, 1, s, &l);
}
/* Read next allocation of deallocation information from the GMEM file and
write an alloc/free information in buf to be processed by GDB (see gnatmem
implementation). */
void
__gnat_gmem_read_next (buf)
char *buf;
{
void *addr;
int size;
char c;
if ((c = fgetc (gmemfile)) == EOF)
{
fclose (gmemfile);
sprintf (buf, "Program exited.");
}
else
{
switch (c)
{
case 'A' :
fread (&addr, sizeof (char *), 1, gmemfile);
fread (&size, sizeof (int), 1, gmemfile);
sprintf (buf, "ALLOC^%d^0x%lx^", size, (long) addr);
break;
case 'D' :
fread (&addr, sizeof (char *), 1, gmemfile);
sprintf (buf, "DEALL^0x%lx^", (long) addr);
break;
default:
puts ("GMEM dump file corrupt");
__gnat_os_exit (1);
}
gmem_read_backtrace ();
}
}
/* Scans the line until the space or new-line character is encountered;
this character is replaced by nul and its position is returned. */
static char *
spc2nul (s)
char *s;
{
while (*++s)
if (*s == ' ' || *s == '\n')
{
*s = 0;
return s;
}
abort ();
}
/* Convert backtrace address in tracebk at position cur_tb_pos to a symbolic
traceback information returned in buf and to be processed by GDB (see
gnatmem implementation). */
void
__gnat_gmem_read_bt_frame (buf)
char *buf;
{
int l = 0;
char s[1000];
char *name, *file;
if (cur_tb_pos >= cur_tb_len)
{
buf [0] = ' ';
buf [1] = '\0';
return;
}
convert_addresses (tracebk + cur_tb_pos, 1, s, &l);
s[l] = '\0';
name = spc2nul (s) + 4;
file = spc2nul (name) + 4;
spc2nul (file);
++cur_tb_pos;
sprintf (buf, "# %s () at %s", name, file);
}

41
gcc/ada/gnat.ads Normal file
View File

@ -0,0 +1,41 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1992-2000 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is the parent package for a library of useful units provided with GNAT
package GNAT is
pragma Pure (GNAT);
end GNAT;

642
gcc/ada/gnat1drv.adb Normal file
View File

@ -0,0 +1,642 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T 1 D R V --
-- --
-- B o d y --
-- --
-- $Revision: 1.129 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Back_End; use Back_End;
with Comperr;
with Csets; use Csets;
with Debug; use Debug;
with Elists;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Frontend;
with Gnatvsn; use Gnatvsn;
with Hostparm;
with Inline;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Namet; use Namet;
with Nlists;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Repinfo; use Repinfo;
with Restrict; use Restrict;
with Sem;
with Sem_Ch13;
with Sem_Warn;
with Sinfo; use Sinfo;
with Sinput.L; use Sinput.L;
with Snames;
with Sprint; use Sprint;
with Stringt;
with Targparm;
with Tree_Gen;
with Treepr; use Treepr;
with Ttypes;
with Types; use Types;
with Uintp;
with Uname; use Uname;
with Urealp;
with Usage;
with System.Assertions;
procedure Gnat1drv is
Main_Unit_Node : Node_Id;
-- Compilation unit node for main unit
Main_Unit_Entity : Node_Id;
-- Compilation unit entity for main unit
Main_Kind : Node_Kind;
-- Kind of main compilation unit node.
Original_Operating_Mode : Operating_Mode_Type;
-- Save operating type specified by options
Back_End_Mode : Back_End.Back_End_Mode_Type;
-- Record back end mode
begin
-- This inner block is set up to catch assertion errors and constraint
-- errors. Since the code for handling these errors can cause another
-- exception to be raised (namely Unrecoverable_Error), we need two
-- nested blocks, so that the outer one handles unrecoverable error.
begin
Osint.Initialize (Compiler);
Scan_Compiler_Arguments;
Osint.Add_Default_Search_Dirs;
Sinput.Initialize;
Lib.Initialize;
Sem.Initialize;
Csets.Initialize;
Uintp.Initialize;
Urealp.Initialize;
Errout.Initialize;
Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Inline.Initialize;
Sem_Ch13.Initialize;
-- Output copyright notice if full list mode
if (Verbose_Mode or Full_List)
and then (not Debug_Flag_7)
then
Write_Eol;
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
Write_Str (" Copyright 1992-2001 Free Software Foundation, Inc.");
Write_Eol;
end if;
-- Acquire target parameters and perform required setup
Targparm.Get_Target_Parameters;
if Targparm.High_Integrity_Mode_On_Target then
Set_No_Run_Time_Mode;
end if;
-- Before we do anything else, adjust certain global values for
-- debug switches which modify their normal natural settings.
if Debug_Flag_8 then
Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
end if;
if Debug_Flag_M then
Targparm.OpenVMS_On_Target := True;
Hostparm.OpenVMS := True;
end if;
if Debug_Flag_FF then
Targparm.Frontend_Layout_On_Target := True;
end if;
-- We take the default exception mechanism into account
if Targparm.ZCX_By_Default_On_Target then
if Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := GCC_ZCX;
else
Exception_Mechanism := Front_End_ZCX;
end if;
end if;
-- We take the command line exception mechanism into account
if Opt.Zero_Cost_Exceptions_Set then
if Opt.Zero_Cost_Exceptions_Val = False then
Exception_Mechanism := Setjmp_Longjmp;
elsif Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := GCC_ZCX;
elsif Targparm.Front_End_ZCX_Support_On_Target
or else Debug_Flag_XX
then
Exception_Mechanism := Front_End_ZCX;
else
Osint.Fail
("Zero Cost Exceptions not supported on this target");
end if;
end if;
-- Check we have exactly one source file, this happens only in
-- the case where the driver is called directly, it cannot happen
-- when gnat1 is invoked from gcc in the normal case.
if Osint.Number_Of_Files /= 1 then
Usage;
Write_Eol;
Osint.Fail ("you must provide one source file");
elsif Usage_Requested then
Usage;
end if;
Original_Operating_Mode := Operating_Mode;
Frontend;
Main_Unit_Node := Cunit (Main_Unit);
Main_Unit_Entity := Cunit_Entity (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
-- Check for suspicious or incorrect body present if we are doing
-- semantic checking. We omit this check in syntax only mode, because
-- in that case we do not know if we need a body or not.
if Operating_Mode /= Check_Syntax
and then
((Main_Kind = N_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else (Main_Kind = N_Generic_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
or else Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation)
then
declare
Sname : Unit_Name_Type := Unit_Name (Main_Unit);
Src_Ind : Source_File_Index;
Fname : File_Name_Type;
procedure Bad_Body (Msg : String);
-- Issue message for bad body found
procedure Bad_Body (Msg : String) is
begin
Error_Msg_N (Msg, Main_Unit_Node);
Error_Msg_Name_1 := Fname;
Error_Msg_N
("remove incorrect body in file{!", Main_Unit_Node);
end Bad_Body;
begin
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body
-- name (but how can we have a body name here ???)
if not Is_Body_Name (Sname) then
Sname := Get_Body_Name (Sname);
end if;
Fname := Get_File_Name (Sname, Subunit => False);
Src_Ind := Load_Source_File (Fname);
-- Case where body is present and it is not a subunit. Exclude
-- the subunit case, because it has nothing to do with the
-- package we are compiling. It is illegal for a child unit
-- and a subunit with the same expanded name (RM 10.2(9)) to
-- appear together in a partition, but there is nothing to
-- stop a compilation environment from having both, and the
-- test here simply allows that. If there is an attempt to
-- include both in a partition, this is diagnosed at bind time.
-- In Ada 83 mode this is not a warning case.
if Src_Ind /= No_Source_File
and then not Source_File_Is_Subunit (Src_Ind)
then
Error_Msg_Name_1 := Sname;
-- Ada 83 case of a package body being ignored. This is not
-- an error as far as the Ada 83 RM is concerned, but it is
-- almost certainly not what is wanted so output a warning.
-- Give this message only if there were no errors, since
-- otherwise it may be incorrect (we may have misinterpreted
-- a junk spec as not needing a body when it really does).
if Main_Kind = N_Package_Declaration
and then Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
then
Error_Msg_N
("package % does not require a body?!", Main_Unit_Node);
Error_Msg_Name_1 := Fname;
Error_Msg_N
("body in file{?! will be ignored", Main_Unit_Node);
-- Ada 95 cases of a body file present when no body is
-- permitted. This we consider to be an error.
else
-- For generic instantiations, we never allow a body
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Bad_Body
("generic instantiation for % does not allow a body");
-- A library unit that is a renaming never allows a body
elsif Main_Kind in N_Renaming_Declaration then
Bad_Body
("renaming declaration for % does not allow a body!");
-- Remaining cases are packages and generic packages.
-- Here we only do the test if there are no previous
-- errors, because if there are errors, they may lead
-- us to incorrectly believe that a package does not
-- allow a body when in fact it does.
elsif not Compilation_Errors then
if Main_Kind = N_Package_Declaration then
Bad_Body ("package % does not allow a body!");
elsif Main_Kind = N_Generic_Package_Declaration then
Bad_Body ("generic package % does not allow a body!");
end if;
end if;
end if;
end if;
end;
end if;
-- Exit if compilation errors detected
if Compilation_Errors then
Treepr.Tree_Dump;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Namet.Finalize;
-- Generate ALI file if specially requested
if Opt.Force_ALI_Tree_File then
Write_ALI (Object => False);
Tree_Gen;
end if;
Exit_Program (E_Errors);
end if;
-- Check for unused with's. We do this whether or not code is generated
Sem_Warn.Check_Unused_Withs;
-- Set Generate_Code on main unit and its spec. We do this even if
-- are not generating code, since Lib-Writ uses this to determine
-- which units get written in the ali file.
Set_Generate_Code (Main_Unit);
-- If we have a corresponding spec, then we need object
-- code for the spec unit as well
if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body
and then not Acts_As_Spec (Main_Unit_Node)
then
Set_Generate_Code
(Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node)));
end if;
-- Check for unused with's. We do this whether or not code is generated
Sem_Warn.Check_Unused_Withs;
-- Case of no code required to be generated, exit indicating no error
if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump;
Errout.Finalize;
Tree_Gen;
Namet.Finalize;
Exit_Program (E_Success);
elsif Original_Operating_Mode = Check_Semantics then
Back_End_Mode := Declarations_Only;
-- All remaining cases are cases in which the user requested that code
-- be generated (i.e. no -gnatc or -gnats switch was used). Check if
-- we can in fact satisfy this request.
-- Cannot generate code if someone has turned off code generation
-- for any reason at all. We will try to figure out a reason below.
elsif Operating_Mode /= Generate_Code then
Back_End_Mode := Skip;
-- We can generate code for a subprogram body unless its corresponding
-- subprogram spec is a generic delaration. Note that the check for
-- No (Library_Unit) here is a defensive check that should not be
-- necessary, since the Library_Unit field should be set properly.
elsif Main_Kind = N_Subprogram_Body
and then not Subunits_Missing
and then (No (Library_Unit (Main_Unit_Node))
or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /=
N_Generic_Subprogram_Declaration
or else Generic_Separately_Compiled (Main_Unit_Entity))
then
Back_End_Mode := Generate_Object;
-- We can generate code for a package body unless its corresponding
-- package spec is a generic declaration. As described above, the
-- check for No (LIbrary_Unit) is a defensive check.
elsif Main_Kind = N_Package_Body
and then not Subunits_Missing
and then (No (Library_Unit (Main_Unit_Node))
or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /=
N_Generic_Package_Declaration
or else Generic_Separately_Compiled (Main_Unit_Entity))
then
Back_End_Mode := Generate_Object;
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
elsif (Main_Kind = N_Package_Declaration
or else
Main_Kind = N_Subprogram_Declaration)
and then
(not Body_Required (Main_Unit_Node)
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
then
Back_End_Mode := Generate_Object;
-- We can generate code for a generic package declaration of a generic
-- subprogram declaration only if does not require a body, and if it
-- is a generic that is separately compiled.
elsif (Main_Kind = N_Generic_Package_Declaration
or else
Main_Kind = N_Generic_Subprogram_Declaration)
and then not Body_Required (Main_Unit_Node)
and then Generic_Separately_Compiled (Main_Unit_Entity)
then
Back_End_Mode := Generate_Object;
-- Compilation units that are renamings do not require bodies,
-- so we can generate code for them.
elsif Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
then
Back_End_Mode := Generate_Object;
-- Compilation units that are generic renamings do not require bodies
-- so we can generate code for them in the separately compiled case
elsif Main_Kind in N_Generic_Renaming_Declaration
and then Generic_Separately_Compiled (Main_Unit_Entity)
then
Back_End_Mode := Generate_Object;
-- In all other cases (specs which have bodies, generics, and bodies
-- where subunits are missing), we cannot generate code and we generate
-- a warning message. Note that generic instantiations are gone at this
-- stage since they have been replaced by their instances.
else
Back_End_Mode := Skip;
end if;
-- At this stage Call_Back_End is set to indicate if the backend
-- should be called to generate code. If it is not set, then code
-- generation has been turned off, even though code was requested
-- by the original command. This is not an error from the user
-- point of view, but it is an error from the point of view of
-- the gcc driver, so we must exit with an error status.
-- We generate an informative message (from the gcc point of view,
-- it is an error message, but from the users point of view this
-- is not an error, just a consequence of compiling something that
-- cannot generate code).
if Back_End_Mode = Skip then
Write_Str ("No code generated for ");
Write_Str ("file ");
Write_Name (Unit_File_Name (Main_Unit));
if Subunits_Missing then
Write_Str (" (missing subunits)");
elsif Main_Kind = N_Subunit then
Write_Str (" (subunit)");
elsif Main_Kind = N_Package_Body
or else Main_Kind = N_Subprogram_Body
then
Write_Str (" (generic unit)");
elsif Main_Kind = N_Subprogram_Declaration then
Write_Str (" (subprogram spec)");
-- Only other case is a package spec
else
Write_Str (" (package spec)");
end if;
Write_Eol;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Treepr.Tree_Dump;
Tree_Gen;
Write_ALI (Object => False);
Namet.Finalize;
-- Exit program with error indication, to kill object file
Exit_Program (E_No_Code);
end if;
-- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also
-- set as indicated by Back_Annotate_Rep_Info being set to True.
-- We don't call for annotations on a subunit, because to process those
-- the back-end requires that the parent(s) be properly compiled.
-- Annotation is also suppressed in the case of compiling for
-- the Java VM, since representations are largely symbolic there.
if Back_End_Mode = Declarations_Only
and then (not (Back_Annotate_Rep_Info or Debug_Flag_AA)
or else Main_Kind = N_Subunit
or else Hostparm.Java_VM)
then
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Write_ALI (Object => False);
Tree_Dump;
Tree_Gen;
Namet.Finalize;
return;
end if;
-- Ensure that we properly register a dependency on system.ads,
-- since even if we do not semantically depend on this, Targparm
-- has read system parameters from the system.ads file.
Lib.Writ.Ensure_System_Dependency;
-- Back end needs to explicitly unlock tables it needs to touch
Atree.Lock;
Elists.Lock;
Fname.UF.Lock;
Inline.Lock;
Lib.Lock;
Nlists.Lock;
Sem.Lock;
Sinput.Lock;
Namet.Lock;
Stringt.Lock;
-- There are cases where the back end emits warnings, e.g. on objects
-- that are too large and will cause Storage_Error. If such a warning
-- appears in a generic context, then it is always appropriately
-- placed on the instance rather than the template, since gigi only
-- deals with generated code in instances (in particular the warning
-- for oversize objects clearly belongs on the instance).
Warn_On_Instance := True;
-- Here we call the backend to generate the output code
Back_End.Call_Back_End (Back_End_Mode);
-- Once the backend is complete, we unlock the names table. This
-- call allows a few extra entries, needed for example for the file
-- name for the library file output.
Namet.Unlock;
-- Validate unchecked conversions (using the values for size
-- and alignment annotated by the backend where possible).
Sem_Ch13.Validate_Unchecked_Conversions;
-- Now we complete output of errors, rep info and the tree info.
-- These are delayed till now, since it is perfectly possible for
-- gigi to generate errors, modify the tree (in particular by setting
-- flags indicating that elaboration is required, and also to back
-- annotate representation information for List_Rep_Info.
Errout.Finalize;
if Opt.List_Representation_Info /= 0 or else Debug_Flag_AA then
List_Rep_Info;
end if;
-- Only write the library if the backend did not generate any error
-- messages. Otherwise signal errors to the driver program so that
-- there will be no attempt to generate an object file.
if Compilation_Errors then
Treepr.Tree_Dump;
Exit_Program (E_Errors);
end if;
Write_ALI (Object => (Back_End_Mode = Generate_Object));
-- Generate the ASIS tree after writing the ALI file, since in
-- ASIS mode, Write_ALI may in fact result in further tree
-- decoration from the original tree file. Note that we dump
-- the tree just before generating it, so that the dump will
-- exactly reflect what is written out.
Treepr.Tree_Dump;
Tree_Gen;
-- Finalize name table and we are all done
Namet.Finalize;
exception
-- Handle fatal internal compiler errors
when System.Assertions.Assert_Failure =>
Comperr.Compiler_Abort ("Assert_Failure");
when Constraint_Error =>
Comperr.Compiler_Abort ("Constraint_Error");
when Program_Error =>
Comperr.Compiler_Abort ("Program_Error");
when Storage_Error =>
-- Assume this is a bug. If it is real, the message will in
-- any case say Storage_Error, giving a strong hint!
Comperr.Compiler_Abort ("Storage_Error");
end;
-- The outer exception handles an unrecoverable error
exception
when Unrecoverable_Error =>
Errout.Finalize;
Set_Standard_Error;
Write_Str ("compilation abandoned");
Write_Eol;
Set_Standard_Output;
Source_Dump;
Tree_Dump;
Exit_Program (E_Errors);
end Gnat1drv;

35
gcc/ada/gnat1drv.ads Normal file
View File

@ -0,0 +1,35 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T 1 D R V --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Main procedure for the GNAT compiler
-- This driver processes a single main unit, generating output object code
-- file.ad[sb] ---> front-end ---> back-end ---> file.o
procedure Gnat1drv;

486
gcc/ada/gnatbind.adb Normal file
View File

@ -0,0 +1,486 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T B I N D --
-- --
-- B o d y --
-- --
-- $Revision: 1.68 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Bcheck; use Bcheck;
with Binde; use Binde;
with Binderr; use Binderr;
with Bindgen; use Bindgen;
with Bindusg;
with Butil; use Butil;
with Csets;
with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Switch; use Switch;
with Types; use Types;
procedure Gnatbind is
Total_Errors : Nat := 0;
-- Counts total errors in all files
Total_Warnings : Nat := 0;
-- Total warnings in all files
Main_Lib_File : File_Name_Type;
-- Current main library file
Std_Lib_File : File_Name_Type;
-- Standard library
Text : Text_Buffer_Ptr;
Id : ALI_Id;
Next_Arg : Positive;
Output_File_Name_Seen : Boolean := False;
Output_File_Name : String_Ptr := new String'("");
procedure Scan_Bind_Arg (Argv : String);
-- Scan and process binder specific arguments. Argv is a single argument.
-- All the one character arguments are still handled by Switch. This
-- routine handles -aO -aI and -I-.
-------------------
-- Scan_Bind_Arg --
-------------------
procedure Scan_Bind_Arg (Argv : String) is
begin
-- Now scan arguments that are specific to the binder and are not
-- handled by the common circuitry in Switch.
if Opt.Output_File_Name_Present
and then not Output_File_Name_Seen
then
Output_File_Name_Seen := True;
if Argv'Length = 0
or else (Argv'Length >= 1
and then (Argv (1) = Switch_Character
or else Argv (1) = '-'))
then
Fail ("output File_Name missing after -o");
else
Output_File_Name := new String'(Argv);
end if;
elsif Argv'Length >= 2
and then (Argv (1) = Switch_Character
or else Argv (1) = '-')
then
-- -I-
if Argv (2 .. Argv'Last) = "I-" then
Opt.Look_In_Primary_Dir := False;
-- -Idir
elsif Argv (2) = 'I' then
Add_Src_Search_Dir (Argv (3 .. Argv'Last));
Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
-- -Ldir
elsif Argv (2) = 'L' then
if Argv'Length >= 3 then
Opt.Bind_For_Library := True;
Opt.Ada_Init_Name :=
new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix);
Opt.Ada_Final_Name :=
new String'(Argv (3 .. Argv'Last) & Opt.Ada_Final_Suffix);
Opt.Ada_Main_Name :=
new String'(Argv (3 .. Argv'Last) & Opt.Ada_Main_Name_Suffix);
-- This option (-Lxxx) implies -n
Opt.Bind_Main_Program := False;
else
Fail
("Prefix of initialization and finalization " &
"procedure names missing in -L");
end if;
-- -Sin -Slo -Shi -Sxx
elsif Argv'Length = 4
and then Argv (2) = 'S'
then
declare
C1 : Character := Argv (3);
C2 : Character := Argv (4);
begin
if C1 in 'a' .. 'z' then
C1 := Character'Val (Character'Pos (C1) - 32);
end if;
if C2 in 'a' .. 'z' then
C2 := Character'Val (Character'Pos (C2) - 32);
end if;
if C1 = 'I' and then C2 = 'N' then
Initialize_Scalars_Mode := 'I';
elsif C1 = 'L' and then C2 = 'O' then
Initialize_Scalars_Mode := 'L';
elsif C1 = 'H' and then C2 = 'I' then
Initialize_Scalars_Mode := 'H';
elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F')
and then
(C2 in '0' .. '9' or else C2 in 'A' .. 'F')
then
Initialize_Scalars_Mode := 'X';
Initialize_Scalars_Val (1) := C1;
Initialize_Scalars_Val (2) := C2;
-- Invalid -S switch, let Switch give error
else
Scan_Binder_Switches (Argv);
end if;
end;
-- -aIdir
elsif Argv'Length >= 3
and then Argv (2 .. 3) = "aI"
then
Add_Src_Search_Dir (Argv (4 .. Argv'Last));
-- -aOdir
elsif Argv'Length >= 3
and then Argv (2 .. 3) = "aO"
then
Add_Lib_Search_Dir (Argv (4 .. Argv'Last));
-- -nostdlib
elsif Argv (2 .. Argv'Last) = "nostdlib" then
Opt.No_Stdlib := True;
-- -nostdinc
elsif Argv (2 .. Argv'Last) = "nostdinc" then
Opt.No_Stdinc := True;
-- -static
elsif Argv (2 .. Argv'Last) = "static" then
Opt.Shared_Libgnat := False;
-- -shared
elsif Argv (2 .. Argv'Last) = "shared" then
Opt.Shared_Libgnat := True;
-- -Mname
elsif Argv'Length >= 3 and then Argv (2) = 'M' then
Opt.Bind_Alternate_Main_Name := True;
Opt.Alternate_Main_Name := new String '(Argv (3 .. Argv'Last));
-- All other options are single character and are handled
-- by Scan_Binder_Switches.
else
Scan_Binder_Switches (Argv);
end if;
-- Not a switch, so must be a file name (if non-empty)
elsif Argv'Length /= 0 then
if Argv'Length > 4
and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali"
then
Set_Main_File_Name (Argv);
else
Set_Main_File_Name (Argv & ".ali");
end if;
end if;
end Scan_Bind_Arg;
-- Start of processing for Gnatbind
begin
Osint.Initialize (Binder);
-- Set default for Shared_Libgnat option
declare
Shared_Libgnat_Default : Character;
pragma Import (C, Shared_Libgnat_Default, "shared_libgnat_default");
SHARED : constant Character := 'H';
STATIC : constant Character := 'T';
begin
pragma Assert
(Shared_Libgnat_Default = SHARED
or else
Shared_Libgnat_Default = STATIC);
Shared_Libgnat := (Shared_Libgnat_Default = SHARED);
end;
-- Use low level argument routines to avoid dragging in the secondary stack
Next_Arg := 1;
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
begin
Fill_Arg (Next_Argv'Address, Next_Arg);
Scan_Bind_Arg (Next_Argv);
end;
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
-- Test for trailing -o switch
if Opt.Output_File_Name_Present
and then not Output_File_Name_Seen
then
Fail ("output file name missing after -o");
end if;
-- Output usage if requested
if Usage_Requested then
Bindusg;
end if;
-- Check that the Ada binder file specified has extension .adb and that
-- the C binder file has extension .c
if Opt.Output_File_Name_Present
and then Output_File_Name_Seen
then
Check_Extensions : declare
Length : constant Natural := Output_File_Name'Length;
Last : constant Natural := Output_File_Name'Last;
begin
if Ada_Bind_File then
if Length <= 4
or else Output_File_Name (Last - 3 .. Last) /= ".adb"
then
Fail ("output file name should have .adb extension");
end if;
else
if Length <= 2
or else Output_File_Name (Last - 1 .. Last) /= ".c"
then
Fail ("output file name should have .c extension");
end if;
end if;
end Check_Extensions;
end if;
Osint.Add_Default_Search_Dirs;
if Verbose_Mode then
Write_Eol;
Write_Str ("GNATBIND ");
Write_Str (Gnat_Version_String);
Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc.");
Write_Eol;
end if;
-- Output usage information if no files
if not More_Lib_Files then
Bindusg;
Exit_Program (E_Fatal);
end if;
-- The block here is to catch the Unrecoverable_Error exception in the
-- case where we exceed the maximum number of permissible errors or some
-- other unrecoverable error occurs.
begin
-- Carry out package initializations. These are initializations which
-- might logically be performed at elaboration time, but Namet at
-- least can't be done that way (because it is used in the Compiler),
-- and we decide to be consistent. Like elaboration, the order in
-- which these calls are made is in some cases important.
Csets.Initialize;
Namet.Initialize;
Initialize_Binderr;
Initialize_ALI;
Initialize_ALI_Source;
if Verbose_Mode then
Write_Eol;
end if;
-- Input ALI files
while More_Lib_Files loop
Main_Lib_File := Next_Main_Lib_File;
if Verbose_Mode then
if Check_Only then
Write_Str ("Checking: ");
else
Write_Str ("Binding: ");
end if;
Write_Name (Main_Lib_File);
Write_Eol;
end if;
Text := Read_Library_Info (Main_Lib_File, True);
Id := Scan_ALI
(F => Main_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False);
Free (Text);
end loop;
-- Add System.Standard_Library to list to ensure that these files are
-- included in the bind, even if not directly referenced from Ada code
-- This is of course omitted in No_Run_Time mode
if not No_Run_Time_Specified then
Name_Buffer (1 .. 12) := "s-stalib.ali";
Name_Len := 12;
Std_Lib_File := Name_Find;
Text := Read_Library_Info (Std_Lib_File, True);
Id :=
Scan_ALI
(F => Std_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False);
Free (Text);
end if;
-- Acquire all information in ALI files that have been read in
for Index in ALIs.First .. ALIs.Last loop
Read_ALI (Index);
end loop;
-- Warn if -f switch used with static model
if Force_RM_Elaboration_Order
and Static_Elaboration_Model_Used
then
Error_Msg ("?static elaboration model used, but -f specified");
Error_Msg ("?may result in missing run-time elaboration checks");
end if;
-- Quit if some file needs compiling
if No_Object_Specified then
raise Unrecoverable_Error;
end if;
-- Build source file table from the ALI files we have read in
Set_Source_Table;
-- Check that main library file is a suitable main program
if Bind_Main_Program
and then ALIs.Table (ALIs.First).Main_Program = None
and then not No_Main_Subprogram
then
Error_Msg_Name_1 := Main_Lib_File;
Error_Msg ("% does not contain a unit that can be a main program");
end if;
-- Perform consistency and correctness checks
Check_Duplicated_Subunits;
Check_Versions;
Check_Consistency;
Check_Configuration_Consistency;
-- Complete bind if no errors
if Errors_Detected = 0 then
Find_Elab_Order;
if Errors_Detected = 0 then
if Elab_Order_Output then
Write_Eol;
Write_Str ("ELABORATION ORDER");
Write_Eol;
for J in Elab_Order.First .. Elab_Order.Last loop
Write_Str (" ");
Write_Unit_Name (Units.Table (Elab_Order.Table (J)).Uname);
Write_Eol;
end loop;
Write_Eol;
end if;
if not Check_Only then
Gen_Output_File (Output_File_Name.all);
end if;
end if;
end if;
Total_Errors := Total_Errors + Errors_Detected;
Total_Warnings := Total_Warnings + Warnings_Detected;
exception
when Unrecoverable_Error =>
Total_Errors := Total_Errors + Errors_Detected;
Total_Warnings := Total_Warnings + Warnings_Detected;
end;
-- All done. Set proper exit status.
Finalize_Binderr;
Namet.Finalize;
if Total_Errors > 0 then
Exit_Program (E_Errors);
elsif Total_Warnings > 0 then
Exit_Program (E_Warnings);
else
Exit_Program (E_Success);
end if;
end Gnatbind;

31
gcc/ada/gnatbind.ads Normal file
View File

@ -0,0 +1,31 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T B I N D --
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Main program of GNAT binder
procedure Gnatbind;

397
gcc/ada/gnatbl.c Normal file
View File

@ -0,0 +1,397 @@
/****************************************************************************
* *
* GNAT COMPILER TOOLS *
* *
* G N A T B L *
* *
* C Implementation File *
* *
* $Revision: 1.65 $
* *
* 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- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
* MA 02111-1307, USA. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
* *
****************************************************************************/
#include "config.h"
#include "system.h"
#if defined (__EMX__) || defined (MSDOS)
#include <process.h>
#endif
#include "adaint.h"
#ifdef VMS
#ifdef exit
#undef exit
#endif
#define exit __posix_exit
#endif
/* These can be set by command line arguments */
char *binder_path = 0;
char *linker_path = 0;
char *exec_file_name = 0;
char *ali_file_name = 0;
#define BIND_ARG_MAX 512
char *bind_args[BIND_ARG_MAX];
int bind_arg_index = -1;
#ifdef MSDOS
char *coff2exe_path = 0;
char *coff2exe_args[] = {(char *) 0, (char *) 0};
char *del_command = 0;
#endif
int verbose = 0;
int o_present = 0;
int g_present = 0;
int link_arg_max = -1;
char **link_args = (char **) 0;
int link_arg_index = -1;
char *gcc_B_arg = 0;
#ifndef DIR_SEPARATOR
#if defined (__EMX__)
#define DIR_SEPARATOR '\\'
#else
#define DIR_SEPARATOR '/'
#endif
#endif
static int linkonly = 0;
static void addarg PARAMS ((char *));
static void process_args PARAMS ((int *, char *[]));
static void
addarg (str)
char *str;
{
int i;
if (++link_arg_index >= link_arg_max)
{
char **new_link_args
= (char **) xcalloc (link_arg_max + 1000, sizeof (char *));
for (i = 0; i <= link_arg_max; i++)
new_link_args [i] = link_args [i];
if (link_args)
free (link_args);
link_arg_max += 1000;
link_args = new_link_args;
}
link_args [link_arg_index] = str;
}
static void
process_args (p_argc, argv)
int *p_argc;
char *argv[];
{
int i, j;
for (i = 1; i < *p_argc; i++)
{
/* -I is passed on to gnatbind */
if (! strncmp( argv[i], "-I", 2))
{
bind_arg_index += 1;
if (bind_arg_index >= BIND_ARG_MAX)
{
fprintf (stderr, "Too many arguments to gnatbind\n");
exit (-1);
}
bind_args[bind_arg_index] = argv[i];
}
/* -B is passed on to gcc */
if (! strncmp (argv [i], "-B", 2))
gcc_B_arg = argv[i];
/* -v turns on verbose option here and is passed on to gcc */
if (! strcmp (argv [i], "-v"))
verbose = 1;
if (! strcmp (argv [i], "-o"))
{
o_present = 1;
exec_file_name = argv [i + 1];
}
if (! strcmp (argv [i], "-g"))
g_present = 1;
if (! strcmp (argv [i], "-gnatbind"))
{
/* Explicit naming of binder. Grab the value then remove the
two arguments from the argument list. */
if ( i + 1 >= *p_argc )
{
fprintf (stderr, "Missing argument for -gnatbind\n");
exit (1);
}
binder_path = __gnat_locate_exec (argv [i + 1], (char *) ".");
if (!binder_path)
{
fprintf (stderr, "Could not locate binder: %s\n", argv [i + 1]);
exit (1);
}
for (j = i + 2; j < *p_argc; j++)
argv [j - 2] = argv [j];
(*p_argc) -= 2;
i--;
}
else if (! strcmp (argv [i], "-linkonly"))
{
/* Don't call the binder. Set the flag and then remove the
argument from the argument list. */
linkonly = 1;
for (j = i + 1; j < *p_argc; j++)
argv [j - 1] = argv [j];
(*p_argc) -= 1;
i--;
}
else if (! strcmp (argv [i], "-gnatlink"))
{
/* Explicit naming of binder. Grab the value then remove the
two arguments from the argument list. */
if (i + 1 >= *p_argc)
{
fprintf (stderr, "Missing argument for -gnatlink\n");
exit (1);
}
linker_path = __gnat_locate_exec (argv [i + 1], (char *) ".");
if (!linker_path)
{
fprintf (stderr, "Could not locate linker: %s\n", argv [i + 1]);
exit (1);
}
for (j = i + 2; j < *p_argc; j++)
argv [j - 2] = argv [j];
(*p_argc) -= 2;
i--;
}
}
}
extern int main PARAMS ((int, char **));
int
main (argc, argv)
int argc;
char **argv;
{
int i, j;
int done_an_ali = 0;
int retcode;
#ifdef VMS
/* Warning: getenv only retrieves the first directory in VAXC$PATH */
char *pathval =
strdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0));
#else
char *pathval = getenv ("PATH");
#endif
char *spawn_args [5];
int spawn_index = 0;
#if defined (__EMX__) || defined(MSDOS)
char *tmppathval = malloc (strlen (pathval) + 3);
strcpy (tmppathval, ".;");
pathval = strcat (tmppathval, pathval);
#endif
process_args (&argc , argv);
if (argc == 1)
{
fprintf
(stdout,
"Usage: %s 'name'.ali\n", argv[0]);
fprintf
(stdout,
" [-o exec_name] -- by default it is 'name'\n");
fprintf
(stdout,
" [-v] -- verbose mode\n");
fprintf
(stdout,
" [-linkonly] -- doesn't call binder\n");
fprintf
(stdout,
" [-gnatbind name] -- full name for gnatbind\n");
fprintf
(stdout,
" [-gnatlink name] -- full name for linker (gcc)\n");
fprintf
(stdout,
" [list of objects] -- non Ada binaries\n");
fprintf
(stdout,
" [linker options] -- other options for linker\n");
exit (1);
}
if (!binder_path && !linkonly)
binder_path = __gnat_locate_exec ((char *) "gnatbind", pathval);
if (!binder_path && !linkonly)
{
fprintf (stderr, "Couldn't locate gnatbind\n");
exit (1);
}
if (!linker_path)
linker_path = __gnat_locate_exec ((char *) "gnatlink", pathval);
if (!linker_path)
{
fprintf (stderr, "Couldn't locate gnatlink\n");
exit (1);
}
#ifdef MSDOS
coff2exe_path = __gnat_locate_regular_file ("coff2exe.bat", pathval);
if (!coff2exe_path)
{
fprintf (stderr, "Couldn't locate %s\n", "coff2exe.bat");
exit (1);
}
else
coff2exe_args[0] = coff2exe_path;
#endif
addarg (linker_path);
for (i = 1; i < argc; i++)
{
int arg_len = strlen (argv [i]);
if (arg_len > 4 && ! strcmp (&argv [i][arg_len - 4], ".ali"))
{
if (done_an_ali)
{
fprintf (stderr,
"Sorry - cannot handle more than one ALI file\n");
exit (1);
}
done_an_ali = 1;
if (__gnat_is_regular_file (argv [i]))
{
ali_file_name = argv[i];
if (!linkonly)
{
/* Run gnatbind */
spawn_index = 0;
spawn_args [spawn_index++] = binder_path;
spawn_args [spawn_index++] = ali_file_name;
for (j = 0 ; j <= bind_arg_index ; j++ )
spawn_args [spawn_index++] = bind_args [j];
spawn_args [spawn_index] = 0;
if (verbose)
{
int i;
for (i = 0; i < 2; i++)
printf ("%s ", spawn_args [i]);
putchar ('\n');
}
retcode = __gnat_portable_spawn (spawn_args);
if (retcode != 0)
exit (retcode);
}
}
else
addarg (argv [i]);
}
#ifdef MSDOS
else if (!strcmp (argv [i], "-o"))
{
addarg (argv [i]);
if (i < argc)
i++;
{
char *ptr = strstr (argv[i], ".exe");
arg_len = strlen (argv [i]);
coff2exe_args[1] = malloc (arg_len + 1);
strcpy (coff2exe_args[1], argv[i]);
if (ptr != NULL && strlen (ptr) == 4)
coff2exe_args[1][arg_len-4] = 0;
addarg (coff2exe_args[1]);
}
}
#endif
else
addarg (argv [i]);
}
if (! done_an_ali)
{
fprintf (stderr, "No \".ali\" file specified\n");
exit (1);
}
addarg (ali_file_name);
addarg (NULL);
if (verbose)
{
int i;
for (i = 0; i < link_arg_index; i++)
printf ("%s ", link_args [i]);
putchar ('\n');
}
retcode = __gnat_portable_spawn (link_args);
if (retcode != 0)
exit (retcode);
#ifdef MSDOS
retcode = __gnat_portable_spawn (coff2exe_args);
if (retcode != 0)
exit (retcode);
if (!g_present)
{
del_command = malloc (strlen (coff2exe_args[1]) + 5);
sprintf (del_command, "del %s", coff2exe_args[1]);
retcode = system (del_command);
}
#endif
exit(0);
}

1696
gcc/ada/gnatchop.adb Normal file
View File

File diff suppressed because it is too large Load Diff

3239
gcc/ada/gnatcmd.adb Normal file
View File

File diff suppressed because it is too large Load Diff

61
gcc/ada/gnatcmd.ads Normal file
View File

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T C M D --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (C) 1996 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This program provides a simple command interface for using GNAT and its
-- associated utilities. The format of switches accepted is intended to
-- be more familiar in style for VMS and DOS users than the standard Unix
-- style switches that are accepted directly.
-- The program is typically called GNAT when it is installed and
-- the two possibile styles of use are:
-- To call gcc:
-- GNAT filename switches
-- To call the tool gnatxxx
-- GNAT xxx filename switches
-- where xxx is the command name (e.g. MAKE for gnatmake). This command name
-- can be abbreviated by giving a prefix (e.g. GNAT MAK) as long as it
-- remains unique.
-- In both cases, filename is in the format appropriate to the operating
-- system in use. The individual commands give more details. In some cases
-- a unit name may be given in place of a file name.
-- The switches start with a slash. Switch names can also be abbreviated
-- where no ambiguity arises. The switches associated with each command
-- are specified by the tables that can be found in the body.
-- Although by convention we use upper case for command names and switches
-- in the documentation, all command and switch names are case insensitive
-- and may be given in upper case or lower case or a mixture.
procedure GNATCmd;

545
gcc/ada/gnatdll.adb Normal file
View File

@ -0,0 +1,545 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T D L L --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1997-2000, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- GNATDLL is a Windows specific tool to build DLL.
-- Both relocatable and non-relocatable DLL are supported
with Ada.Text_IO;
with Ada.Strings.Unbounded;
with Ada.Exceptions;
with Ada.Command_Line;
with GNAT.OS_Lib;
with GNAT.Command_Line;
with Gnatvsn;
with MDLL.Files;
with MDLL.Tools;
procedure Gnatdll is
use GNAT;
use Ada;
use MDLL;
use Ada.Strings.Unbounded;
use type OS_Lib.Argument_List;
procedure Syntax;
-- print out usage.
procedure Check (Filename : in String);
-- check that filename exist.
procedure Parse_Command_Line;
-- parse the command line arguments of gnatdll.
procedure Check_Context;
-- check the context before runing any commands to build the library.
Syntax_Error : exception;
Context_Error : exception;
Help : Boolean := False;
Version : constant String := Gnatvsn.Gnat_Version_String;
-- default address for non relocatable DLL (Win32)
Default_DLL_Address : constant String := "0x11000000";
Lib_Filename : Unbounded_String := Null_Unbounded_String;
Def_Filename : Unbounded_String := Null_Unbounded_String;
List_Filename : Unbounded_String := Null_Unbounded_String;
DLL_Address : Unbounded_String :=
To_Unbounded_String (Default_DLL_Address);
-- list of objects to put inside the library
Objects_Files : Argument_List_Access := Null_Argument_List_Access;
-- for each Ada files specified we keep record of the corresponding
-- Ali. This list of ali is used to build the binder program.
Ali_Files : Argument_List_Access := Null_Argument_List_Access;
-- a list of options set in the command line.
Options : Argument_List_Access := Null_Argument_List_Access;
-- gnat linker and binder args options
Largs_Options : Argument_List_Access := Null_Argument_List_Access;
Bargs_Options : Argument_List_Access := Null_Argument_List_Access;
type Build_Mode_State is (Import_Lib, Dynamic_Lib, Nil);
Build_Mode : Build_Mode_State := Nil;
Must_Build_Relocatable : Boolean := True;
Build_Import : Boolean := True;
------------
-- Syntax --
------------
procedure Syntax is
use Text_IO;
begin
Put_Line ("Usage : gnatdll [options] [list-of-files]");
New_Line;
Put_Line
("[list-of-files] a list of Ada libraries (.ali) and/or " &
"foreign object files");
New_Line;
Put_Line ("[options] can be");
Put_Line (" -h help - display this message");
Put_Line (" -v verbose");
Put_Line (" -q quiet");
Put_Line (" -k remove @nn suffix from exported names");
Put_Line (" -Idir Specify source and object files search path");
Put_Line (" -l file " &
"file contains a list-of-files to be added to the library");
Put_Line (" -e file definition file containing exports");
Put_Line
(" -d file put objects in the relocatable dynamic library <file>");
Put_Line (" -a[addr] build non-relocatable DLL at address <addr>");
Put_Line (" if <addr> is not specified use " &
Default_DLL_Address);
Put_Line (" -n no-import - do not create the import library");
Put_Line (" -bargs binder option");
Put_Line (" -largs linker (library builder) option");
end Syntax;
-----------
-- Check --
-----------
procedure Check (Filename : in String) is
begin
if not OS_Lib.Is_Regular_File (Filename) then
Exceptions.Raise_Exception (Context_Error'Identity,
"Error: " & Filename & " not found.");
end if;
end Check;
------------------------
-- Parse_Command_Line --
------------------------
procedure Parse_Command_Line is
use GNAT.Command_Line;
procedure Add_File (Filename : in String);
-- add one file to the list of file to handle
procedure Add_Files_From_List (List_Filename : in String);
-- add the files listed in List_Filename (one by line) to the list
-- of file to handle
procedure Ali_To_Object_List;
-- for each ali file in Afiles set put a corresponding object file in
-- Ofiles set.
-- these are arbitrary limits, a better way will be to use linked list.
Max_Files : constant := 5_000;
Max_Options : constant := 100;
-- objects files to put in the library
Ofiles : OS_Lib.Argument_List (1 .. Max_Files);
O : Positive := Ofiles'First;
-- ali files.
Afiles : OS_Lib.Argument_List (1 .. Max_Files);
A : Positive := Afiles'First;
-- gcc options.
Gopts : OS_Lib.Argument_List (1 .. Max_Options);
G : Positive := Gopts'First;
-- largs options
Lopts : OS_Lib.Argument_List (1 .. Max_Options);
L : Positive := Lopts'First;
-- bargs options
Bopts : OS_Lib.Argument_List (1 .. Max_Options);
B : Positive := Bopts'First;
--------------
-- Add_File --
--------------
procedure Add_File (Filename : in String) is
begin
-- others files are to be put inside the dynamic library
if Files.Is_Ali (Filename) then
Check (Filename);
-- record it to generate the binder program when
-- building dynamic library
Afiles (A) := new String'(Filename);
A := A + 1;
elsif Files.Is_Obj (Filename) then
Check (Filename);
-- just record this object file
Ofiles (O) := new String'(Filename);
O := O + 1;
else
-- unknown file type
Exceptions.Raise_Exception
(Syntax_Error'Identity,
"don't know what to do with " & Filename & " !");
end if;
end Add_File;
-------------------------
-- Add_Files_From_List --
-------------------------
procedure Add_Files_From_List (List_Filename : in String) is
File : Text_IO.File_Type;
Buffer : String (1 .. 500);
Last : Natural;
begin
Text_IO.Open (File, Text_IO.In_File, List_Filename);
while not Text_IO.End_Of_File (File) loop
Text_IO.Get_Line (File, Buffer, Last);
Add_File (Buffer (1 .. Last));
end loop;
Text_IO.Close (File);
end Add_Files_From_List;
------------------------
-- Ali_To_Object_List --
------------------------
procedure Ali_To_Object_List is
begin
for K in 1 .. A - 1 loop
Ofiles (O) := new String'(Files.Ext_To (Afiles (K).all, "o"));
O := O + 1;
end loop;
end Ali_To_Object_List;
begin
Initialize_Option_Scan ('-', False, "bargs largs");
-- scan gnatdll switches
loop
case Getopt ("h v q k a? d: e: l: n I:") is
when ASCII.Nul =>
exit;
when 'h' =>
Help := True;
when 'v' =>
-- verbose mode on.
MDLL.Verbose := True;
if MDLL.Quiet then
Exceptions.Raise_Exception
(Syntax_Error'Identity,
"impossible to use -q and -v together.");
end if;
when 'q' =>
-- quiet mode on.
MDLL.Quiet := True;
if MDLL.Verbose then
Exceptions.Raise_Exception
(Syntax_Error'Identity,
"impossible to use -v and -q together.");
end if;
when 'k' =>
MDLL.Kill_Suffix := True;
when 'a' =>
if Parameter = "" then
-- default address for a relocatable dynamic library.
-- address for a non relocatable dynamic library.
DLL_Address := To_Unbounded_String (Default_DLL_Address);
else
DLL_Address := To_Unbounded_String (Parameter);
end if;
Must_Build_Relocatable := False;
when 'e' =>
Def_Filename := To_Unbounded_String (Parameter);
when 'd' =>
-- build a non relocatable DLL.
Lib_Filename := To_Unbounded_String (Parameter);
if Def_Filename = Null_Unbounded_String then
Def_Filename := To_Unbounded_String
(Files.Ext_To (Parameter, "def"));
end if;
Build_Mode := Dynamic_Lib;
when 'n' =>
Build_Import := False;
when 'l' =>
List_Filename := To_Unbounded_String (Parameter);
when 'I' =>
Gopts (G) := new String'("-I" & Parameter);
G := G + 1;
when others =>
raise Invalid_Switch;
end case;
end loop;
-- get parameters
loop
declare
File : constant String := Get_Argument (Do_Expansion => True);
begin
exit when File'Length = 0;
Add_File (File);
end;
end loop;
-- get largs parameters
Goto_Section ("largs");
loop
case Getopt ("*") is
when ASCII.Nul =>
exit;
when others =>
Lopts (L) := new String'(Full_Switch);
L := L + 1;
end case;
end loop;
-- get bargs parameters
Goto_Section ("bargs");
loop
case Getopt ("*") is
when ASCII.Nul =>
exit;
when others =>
Bopts (B) := new String'(Full_Switch);
B := B + 1;
end case;
end loop;
-- if list filename has been specified parse it
if List_Filename /= Null_Unbounded_String then
Add_Files_From_List (To_String (List_Filename));
end if;
-- check if the set of parameters are compatible.
if Build_Mode = Nil and then not Help and then not Verbose then
Exceptions.Raise_Exception
(Syntax_Error'Identity,
"nothing to do.");
end if;
-- check if we want to build an import library (option -e and no file
-- specified)
if Build_Mode = Dynamic_Lib
and then A = Afiles'First
and then O = Ofiles'First
then
Build_Mode := Import_Lib;
end if;
if O /= Ofiles'First then
Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1));
end if;
if A /= Afiles'First then
Ali_Files := new OS_Lib.Argument_List'(Afiles (1 .. A - 1));
end if;
if G /= Gopts'First then
Options := new OS_Lib.Argument_List'(Gopts (1 .. G - 1));
end if;
if L /= Lopts'First then
Largs_Options := new OS_Lib.Argument_List'(Lopts (1 .. L - 1));
end if;
if B /= Bopts'First then
Bargs_Options := new OS_Lib.Argument_List'(Bopts (1 .. B - 1));
end if;
exception
when Invalid_Switch =>
Exceptions.Raise_Exception
(Syntax_Error'Identity,
Message => "Invalid Switch " & Full_Switch);
when Invalid_Parameter =>
Exceptions.Raise_Exception
(Syntax_Error'Identity,
Message => "No parameter for " & Full_Switch);
end Parse_Command_Line;
-------------------
-- Check_Context --
-------------------
procedure Check_Context is
begin
Check (To_String (Def_Filename));
-- check that each object file specified exist
-- raises Context_Error if it does not.
for F in Objects_Files'Range loop
Check (Objects_Files (F).all);
end loop;
end Check_Context;
begin
if Ada.Command_Line.Argument_Count = 0 then
Help := True;
else
Parse_Command_Line;
end if;
if MDLL.Verbose or else Help then
Text_IO.New_Line;
Text_IO.Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder");
Text_IO.New_Line;
end if;
MDLL.Tools.Locate;
if Help
or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1)
then
Syntax;
else
Check_Context;
case Build_Mode is
when Import_Lib =>
MDLL.Build_Import_Library (To_String (Lib_Filename),
To_String (Def_Filename));
when Dynamic_Lib =>
MDLL.Build_Dynamic_Library
(Objects_Files.all,
Ali_Files.all,
Options.all,
Bargs_Options.all,
Largs_Options.all,
To_String (Lib_Filename),
To_String (Def_Filename),
To_String (DLL_Address),
Build_Import,
Must_Build_Relocatable);
when Nil =>
null;
end case;
end if;
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
exception
when SE : Syntax_Error =>
Text_IO.Put_Line ("Syntax error : " & Exceptions.Exception_Message (SE));
Text_IO.New_Line;
Syntax;
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when E : Tools_Error | Context_Error =>
Text_IO.Put_Line (Exceptions.Exception_Message (E));
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when others =>
Text_IO.Put_Line ("gnatdll: INTERNAL ERROR. Please report");
Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
end Gnatdll;

266
gcc/ada/gnatfind.adb Normal file
View File

@ -0,0 +1,266 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T F I N D --
-- --
-- B o d y --
-- --
-- $Revision: 1.26 $
-- --
-- Copyright (C) 1998-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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Xr_Tabls;
with Xref_Lib; use Xref_Lib;
with Ada.Text_IO;
with GNAT.Command_Line;
with Gnatvsn;
with Osint;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
---------------
-- Gnatfind --
---------------
procedure Gnatfind is
Output_Ref : Boolean := False;
Pattern : Xref_Lib.Search_Pattern;
Local_Symbols : Boolean := True;
Prj_File : File_Name_String;
Prj_File_Length : Natural := 0;
Nb_File : Natural := 0;
Usage_Error : exception;
Full_Path_Name : Boolean := False;
Have_Entity : Boolean := False;
Wide_Search : Boolean := True;
Glob_Mode : Boolean := True;
Der_Info : Boolean := False;
Type_Tree : Boolean := False;
Read_Only : Boolean := False;
Source_Lines : Boolean := False;
Has_File_In_Entity : Boolean := False;
-- Will be true if a file name was specified in the entity
procedure Parse_Cmd_Line;
-- Parse every switch on the command line
procedure Write_Usage;
-- Print a small help page for program usage
--------------------
-- Parse_Cmd_Line --
--------------------
procedure Parse_Cmd_Line is
begin
loop
case GNAT.Command_Line.Getopt ("a aI: aO: d e f g h I: p: r s t") is
when ASCII.NUL =>
exit;
when 'a' =>
if GNAT.Command_Line.Full_Switch = "a" then
Read_Only := True;
elsif GNAT.Command_Line.Full_Switch = "aI" then
Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
else
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
end if;
when 'd' =>
Der_Info := True;
when 'e' =>
Glob_Mode := False;
when 'f' =>
Full_Path_Name := True;
when 'g' =>
Local_Symbols := False;
when 'h' =>
Write_Usage;
when 'I' =>
Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
when 'p' =>
declare
S : constant String := GNAT.Command_Line.Parameter;
begin
Prj_File_Length := S'Length;
Prj_File (1 .. Prj_File_Length) := S;
end;
when 'r' =>
Output_Ref := True;
when 's' =>
Source_Lines := True;
when 't' =>
Type_Tree := True;
when others =>
Write_Usage;
end case;
end loop;
-- Get the other arguments
loop
declare
S : constant String := GNAT.Command_Line.Get_Argument;
begin
exit when S'Length = 0;
-- First argument is the pattern
if not Have_Entity then
Add_Entity (Pattern, S, Glob_Mode);
Have_Entity := True;
if not Has_File_In_Entity
and then Index (S, ":") /= 0
then
Has_File_In_Entity := True;
end if;
-- Next arguments are the files to search
else
Add_File (S);
Wide_Search := False;
Nb_File := Nb_File + 1;
end if;
end;
end loop;
exception
when GNAT.Command_Line.Invalid_Switch =>
Ada.Text_IO.Put_Line ("Invalid switch : "
& GNAT.Command_Line.Full_Switch);
Write_Usage;
when GNAT.Command_Line.Invalid_Parameter =>
Ada.Text_IO.Put_Line ("Parameter missing for : "
& GNAT.Command_Line.Parameter);
Write_Usage;
when Xref_Lib.Invalid_Argument =>
Ada.Text_IO.Put_Line ("Invalid line or column in the pattern");
Write_Usage;
end Parse_Cmd_Line;
-----------------
-- Write_Usage --
-----------------
procedure Write_Usage is
use Ada.Text_IO;
begin
Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String
& " Copyright 1998-2001, Ada Core Technologies Inc.");
Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] "
& "[file1 file2 ...]");
New_Line;
Put_Line (" pattern Name of the entity to look for (can have "
& "wildcards)");
Put_Line (" sourcefile Only find entities referenced from this "
& "file");
Put_Line (" line Only find entities referenced from this line "
& "of file");
Put_Line (" column Only find entities referenced from this columns"
& " of file");
Put_Line (" file ... Set of Ada source files to search for "
& "references. This parameters are optional");
New_Line;
Put_Line ("gnatfind switches:");
Put_Line (" -a Consider all files, even when the ali file is "
& "readonly");
Put_Line (" -aIdir Specify source files search path");
Put_Line (" -aOdir Specify library/object files search path");
Put_Line (" -d Output derived type information");
Put_Line (" -e Use the full regular expression set for pattern");
Put_Line (" -f Output full path name");
Put_Line (" -g Output information only for global symbols");
Put_Line (" -Idir Like -aIdir -aOdir");
Put_Line (" -p file Use file as the default project file");
Put_Line (" -r Find all references (default to find declaration"
& " only)");
Put_Line (" -s Print source line");
Put_Line (" -t Print type hierarchy");
New_Line;
raise Usage_Error;
end Write_Usage;
begin
Osint.Initialize (Osint.Compiler);
Parse_Cmd_Line;
if not Have_Entity then
Write_Usage;
end if;
-- Special case to speed things up: if the user has a command line of the
-- form 'gnatfind entity:file', ie has specified a file and only wants the
-- bodies and specs, then we can restrict the search to the .ali file
-- associated with 'file'.
if Has_File_In_Entity
and then not Output_Ref
then
Wide_Search := False;
end if;
-- Find the project file
if Prj_File_Length = 0 then
Xr_Tabls.Create_Project_File (Default_Project_File ("."));
else
Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length));
end if;
-- Fill up the table
if Type_Tree and then Nb_File > 1 then
Ada.Text_IO.Put_Line ("Error: for type hierarchy output you must "
& "specify only one file.");
Ada.Text_IO.New_Line;
Write_Usage;
end if;
Search (Pattern, Local_Symbols, Wide_Search, Read_Only,
Der_Info, Type_Tree);
if Source_Lines then
Xr_Tabls.Grep_Source_Files;
end if;
Print_Gnatfind (Output_Ref, Full_Path_Name);
exception
when Usage_Error =>
null;
end Gnatfind;

150
gcc/ada/gnatkr.adb Normal file
View File

@ -0,0 +1,150 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T K R --
-- --
-- B o d y --
-- --
-- $Revision: 1.18 $
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Gnatvsn;
with Krunch;
with System.IO; use System.IO;
procedure Gnatkr is
pragma Ident (Gnatvsn.Gnat_Version_String);
Count : Natural;
Maxlen : Integer;
Exit_Program : exception;
function Get_Maximum_File_Name_Length return Integer;
pragma Import (C, Get_Maximum_File_Name_Length,
"__gnat_get_maximum_file_name_length");
begin
Count := Argument_Count;
if Count < 1 or else Count > 2 then
Put_Line ("Usage: gnatkr filename[.extension] [krunch-count]");
raise Exit_Program;
else
-- If the length (krunch-count) argument is omitted use the system
-- default if there is one, otherwise use 8.
if Count = 1 then
Maxlen := Get_Maximum_File_Name_Length;
if Maxlen = -1 then
Maxlen := 8;
end if;
else
Maxlen := 0;
for J in Argument (2)'Range loop
if Argument (2) (J) /= ' ' then
if Argument (2) (J) not in '0' .. '9' then
Put_Line ("Illegal argument for krunch-count");
raise Exit_Program;
else
Maxlen := Maxlen * 10 +
Character'Pos (Argument (2) (J)) - Character'Pos ('0');
end if;
end if;
end loop;
-- Zero means crunch only system files
if Maxlen = 0 then
Maxlen := Natural'Last;
end if;
end if;
declare
Fname : String := Argument (1);
Klen : Natural := Fname'Length;
Extp : Boolean := False;
-- True if extension is present
Ext : Natural := 0;
-- If extension is present, points to it (init to prevent warning)
begin
-- Remove .adb or .ads extension if present (recognized only if the
-- name is all lower case and contains no other instances of dots)
if Klen > 4
and then Fname (Klen - 3 .. Klen - 1) = ".ad"
and then (Fname (Klen) = 's' or else Fname (Klen) = 'b')
then
Extp := True;
for J in 1 .. Klen - 4 loop
if Is_Upper (Fname (J)) or else Fname (J) = '.' then
Extp := False;
end if;
end loop;
if Extp then
Klen := Klen - 4;
Ext := Klen + 1;
end if;
else
Extp := False;
end if;
-- Fold to lower case and replace dots by dashes
for J in 1 .. Klen loop
Fname (J) := To_Lower (Fname (J));
if Fname (J) = '.' then
Fname (J) := '-';
end if;
end loop;
Krunch (Fname, Klen, Maxlen, False);
Put (Fname (1 .. Klen));
if Extp then
Put (Fname (Ext .. Fname'Length));
end if;
New_Line;
end;
end if;
Set_Exit_Status (Success);
exception
when Exit_Program =>
Set_Exit_Status (Failure);
end Gnatkr;

42
gcc/ada/gnatkr.ads Normal file
View File

@ -0,0 +1,42 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T K R --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a small utility program that incorporates the file krunching
-- algorithm used by the GNAT compiler (when the -gnatk switch is used)
-- gnatkr filename length
-- where length is a decimal value, outputs to standard output the krunched
-- name, followed by the original input file name. The file name has an
-- optional extension, which, if present, is copied unchanged to the output.
-- The length argument is optional and defaults to the system default if
-- there is one, otherwise to 8.
procedure Gnatkr;
-- Execute above described command. This is an Ada main program which
-- sets an exit status (set to Success or Failure as appropriate)

Some files were not shown because too many files have changed in this diff Show More