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

New Language: Ada 

From-SVN: r45953
This commit is contained in:
Richard Kenner 2001-10-02 09:55:47 -04:00
parent 84481f762f
commit d23b8f573b
225 changed files with 63455 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
gcc/ada/a-astaco.adb Normal file
View File

@ -0,0 +1,69 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L --
-- --
-- B o d y --
-- --
-- $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. --
-- --
-- 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 a dummy body, which will not normally be compiled when used with
-- standard versions of GNAT, which do not support this package. See comments
-- in spec for further details.
package body Ada.Asynchronous_Task_Control is
--------------
-- Continue --
--------------
procedure Continue (T : Ada.Task_Identification.Task_Id) is
begin
null;
end Continue;
----------
-- Hold --
----------
procedure Hold (T : Ada.Task_Identification.Task_Id) is
begin
raise Program_Error;
end Hold;
-------------
-- Is_Held --
-------------
function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean is
begin
return False;
end Is_Held;
end Ada.Asynchronous_Task_Control;

41
gcc/ada/a-astaco.ads Normal file
View File

@ -0,0 +1,41 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- This unit is not implemented in typical GNAT implementations that
-- lie on top of operating systems, because it is infeasible to implement
-- in such environments. The RM anticipates this situation (RM D.11(10)),
-- and permits an implementation to leave this unimplemented even if the
-- Real-Time Systems annex is fully supported.
-- If a target environment provides appropriate support for this package,
-- then the Unimplemented_Unit pragma should be removed from this spec,
-- and an appropriate body provided. The framework for such a body is
-- included in the distributed sources.
with Ada.Task_Identification;
package Ada.Asynchronous_Task_Control is
pragma Unimplemented_Unit;
procedure Hold (T : Ada.Task_Identification.Task_Id);
procedure Continue (T : Ada.Task_Identification.Task_Id);
function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean;
end Ada.Asynchronous_Task_Control;

113
gcc/ada/a-caldel.adb Normal file
View File

@ -0,0 +1,113 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . C A L E N D A R . D E L A Y S --
-- --
-- B o d y --
-- --
-- $Revision: 1.37 $
-- --
-- Copyright (C) 1991-2001 Florida State University --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.OS_Primitives;
-- Used for Delay_Modes
-- Max_Sensible_Delay
with System.Soft_Links;
-- Used for Timed_Delay
package body Ada.Calendar.Delays is
package OSP renames System.OS_Primitives;
package SSL renames System.Soft_Links;
use type SSL.Timed_Delay_Call;
-- Earlier, the following operations were implemented using
-- System.Time_Operations. The idea was to avoid sucking in the tasking
-- packages. This did not work. Logically, we can't have it both ways.
-- There is no way to implement time delays that will have correct task
-- semantics without reference to the tasking run-time system.
-- To achieve this goal, we now use soft links.
-----------------------
-- Local Subprograms --
-----------------------
procedure Timed_Delay_NT (Time : Duration; Mode : Integer);
-- Timed delay procedure used when no tasking is active
---------------
-- Delay_For --
---------------
procedure Delay_For (D : Duration) is
begin
SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay),
OSP.Relative);
end Delay_For;
-----------------
-- Delay_Until --
-----------------
procedure Delay_Until (T : Time) is
begin
SSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar);
end Delay_Until;
--------------------
-- Timed_Delay_NT --
--------------------
procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is
begin
OSP.Timed_Delay (Time, Mode);
end Timed_Delay_NT;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : Time) return Duration is
begin
return Duration (T);
end To_Duration;
begin
-- Set up the Timed_Delay soft link to the non tasking version
-- if it has not been already set.
-- If tasking is present, Timed_Delay has already set this soft
-- link, or this will be overriden during the elaboration of
-- System.Tasking.Initialization
if SSL.Timed_Delay = null then
SSL.Timed_Delay := Timed_Delay_NT'Access;
end if;
end Ada.Calendar.Delays;

59
gcc/ada/a-caldel.ads Normal file
View File

@ -0,0 +1,59 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . C A L E N D A R . D E L A Y S --
-- --
-- S p e c --
-- --
-- $Revision: 1.16 $ --
-- --
-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package implements Calendar.Time delays using protected objects.
-- Note: the compiler generates direct calls to this interface, in the
-- processing of time types.
package Ada.Calendar.Delays is
procedure Delay_For (D : Duration);
-- Delay until an interval of length (at least) D seconds has passed,
-- or the task is aborted to at least the current ATC nesting level.
-- This is an abort completion point.
-- The body of this procedure must perform all the processing
-- required for an abortion point.
procedure Delay_Until (T : Time);
-- Delay until Clock has reached (at least) time T,
-- or the task is aborted to at least the current ATC nesting level.
-- The body of this procedure must perform all the processing
-- required for an abortion point.
function To_Duration (T : Time) return Duration;
end Ada.Calendar.Delays;

490
gcc/ada/a-calend.adb Normal file
View File

@ -0,0 +1,490 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C A L E N D A R --
-- --
-- B o d y --
-- --
-- $Revision: 1.51 $
-- --
-- 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 System.OS_Primitives;
-- used for Clock
package body Ada.Calendar is
------------------------------
-- Use of Pragma Unsuppress --
------------------------------
-- This implementation of Calendar takes advantage of the permission in
-- Ada 95 of using arithmetic overflow checks to check for out of bounds
-- time values. This means that we must catch the constraint error that
-- results from arithmetic overflow, so we use pragma Unsuppress to make
-- sure that overflow is enabled, using software overflow checking if
-- necessary. That way, compiling Calendar with options to suppress this
-- checking will not affect its correctness.
------------------------
-- Local Declarations --
------------------------
type Char_Pointer is access Character;
subtype int is Integer;
subtype long is Long_Integer;
-- Synonyms for C types. We don't want to get them from Interfaces.C
-- because there is no point in loading that unit just for calendar.
type tm is record
tm_sec : int; -- seconds after the minute (0 .. 60)
tm_min : int; -- minutes after the hour (0 .. 59)
tm_hour : int; -- hours since midnight (0 .. 24)
tm_mday : int; -- day of the month (1 .. 31)
tm_mon : int; -- months since January (0 .. 11)
tm_year : int; -- years since 1900
tm_wday : int; -- days since Sunday (0 .. 6)
tm_yday : int; -- days since January 1 (0 .. 365)
tm_isdst : int; -- Daylight Savings Time flag (-1 .. +1)
tm_gmtoff : long; -- offset from CUT in seconds
tm_zone : Char_Pointer; -- timezone abbreviation
end record;
type tm_Pointer is access all tm;
subtype time_t is long;
type time_t_Pointer is access all time_t;
procedure localtime_r (C : time_t_Pointer; res : tm_Pointer);
pragma Import (C, localtime_r, "__gnat_localtime_r");
function mktime (TM : tm_Pointer) return time_t;
pragma Import (C, mktime);
-- mktime returns -1 in case the calendar time given by components of
-- TM.all cannot be represented.
-- The following constants are used in adjusting Ada dates so that they
-- fit into the range that can be handled by Unix (1970 - 2038). The trick
-- is that the number of days in any four year period in the Ada range of
-- years (1901 - 2099) has a constant number of days. This is because we
-- have the special case of 2000 which, contrary to the normal exception
-- for centuries, is a leap year after all.
Unix_Year_Min : constant := 1970;
Unix_Year_Max : constant := 2038;
Ada_Year_Min : constant := 1901;
Ada_Year_Max : constant := 2099;
-- Some basic constants used throughout
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
Days_In_4_Years : constant := 365 * 3 + 366;
Seconds_In_4_Years : constant := 86_400 * Days_In_4_Years;
Seconds_In_4_YearsD : constant Duration := Duration (Seconds_In_4_Years);
---------
-- "+" --
---------
function "+" (Left : Time; Right : Duration) return Time is
pragma Unsuppress (Overflow_Check);
begin
return (Left + Time (Right));
exception
when Constraint_Error =>
raise Time_Error;
end "+";
function "+" (Left : Duration; Right : Time) return Time is
pragma Unsuppress (Overflow_Check);
begin
return (Time (Left) + Right);
exception
when Constraint_Error =>
raise Time_Error;
end "+";
---------
-- "-" --
---------
function "-" (Left : Time; Right : Duration) return Time is
pragma Unsuppress (Overflow_Check);
begin
return Left - Time (Right);
exception
when Constraint_Error =>
raise Time_Error;
end "-";
function "-" (Left : Time; Right : Time) return Duration is
pragma Unsuppress (Overflow_Check);
begin
return Duration (Left) - Duration (Right);
exception
when Constraint_Error =>
raise Time_Error;
end "-";
---------
-- "<" --
---------
function "<" (Left, Right : Time) return Boolean is
begin
return Duration (Left) < Duration (Right);
end "<";
----------
-- "<=" --
----------
function "<=" (Left, Right : Time) return Boolean is
begin
return Duration (Left) <= Duration (Right);
end "<=";
---------
-- ">" --
---------
function ">" (Left, Right : Time) return Boolean is
begin
return Duration (Left) > Duration (Right);
end ">";
----------
-- ">=" --
----------
function ">=" (Left, Right : Time) return Boolean is
begin
return Duration (Left) >= Duration (Right);
end ">=";
-----------
-- Clock --
-----------
function Clock return Time is
begin
return Time (System.OS_Primitives.Clock);
end Clock;
---------
-- Day --
---------
function Day (Date : Time) return Day_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DD;
end Day;
-----------
-- Month --
-----------
function Month (Date : Time) return Month_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DM;
end Month;
-------------
-- Seconds --
-------------
function Seconds (Date : Time) return Day_Duration is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DS;
end Seconds;
-----------
-- Split --
-----------
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration)
is
-- The following declare bounds for duration that are comfortably
-- wider than the maximum allowed output result for the Ada range
-- of representable split values. These are used for a quick check
-- that the value is not wildly out of range.
Low : constant := (Ada_Year_Min - Unix_Year_Min - 2) * 365 * 86_400;
High : constant := (Ada_Year_Max - Unix_Year_Min + 2) * 365 * 86_400;
LowD : constant Duration := Duration (Low);
HighD : constant Duration := Duration (High);
-- The following declare the maximum duration value that can be
-- successfully converted to a 32-bit integer suitable for passing
-- to the localtime_r function. Note that we cannot assume that the
-- localtime_r function expands to accept 64-bit input on a 64-bit
-- machine, but we can count on a 32-bit range on all machines.
Max_Time : constant := 2 ** 31 - 1;
Max_TimeD : constant Duration := Duration (Max_Time);
-- Finally the actual variables used in the computation
D : Duration;
Frac_Sec : Duration;
Year_Val : Integer;
Adjusted_Seconds : aliased time_t;
Tm_Val : aliased tm;
begin
-- For us a time is simply a signed duration value, so we work with
-- this duration value directly. Note that it can be negative.
D := Duration (Date);
-- First of all, filter out completely ludicrous values. Remember
-- that we use the full stored range of duration values, which may
-- be significantly larger than the allowed range of Ada times. Note
-- that these checks are wider than required to make absolutely sure
-- that there are no end effects from time zone differences.
if D < LowD or else D > HighD then
raise Time_Error;
end if;
-- The unix localtime_r function is more or less exactly what we need
-- here. The less comes from the fact that it does not support the
-- required range of years (the guaranteed range available is only
-- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
-- If we have a value outside this range, then we first adjust it
-- to be in the required range by adding multiples of four years.
-- For the range we are interested in, the number of days in any
-- consecutive four year period is constant. Then we do the split
-- on the adjusted value, and readjust the years value accordingly.
Year_Val := 0;
while D < 0.0 loop
D := D + Seconds_In_4_YearsD;
Year_Val := Year_Val - 4;
end loop;
while D > Max_TimeD loop
D := D - Seconds_In_4_YearsD;
Year_Val := Year_Val + 4;
end loop;
-- Now we need to take the value D, which is now non-negative, and
-- break it down into seconds (to pass to the localtime_r function)
-- and fractions of seconds (for the adjustment below).
-- Surprisingly there is no easy way to do this in Ada, and certainly
-- no easy way to do it and generate efficient code. Therefore we
-- do it at a low level, knowing that it is really represented as
-- an integer with units of Small
declare
type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1;
for D_Int'Size use Duration'Size;
Small_Div : constant D_Int := D_Int (1.0 / Duration'Small);
D_As_Int : D_Int;
function To_D_As_Int is new Unchecked_Conversion (Duration, D_Int);
function To_Duration is new Unchecked_Conversion (D_Int, Duration);
begin
D_As_Int := To_D_As_Int (D);
Adjusted_Seconds := time_t (D_As_Int / Small_Div);
Frac_Sec := To_Duration (D_As_Int rem Small_Div);
end;
localtime_r (Adjusted_Seconds'Unchecked_Access, Tm_Val'Unchecked_Access);
Year_Val := Tm_Val.tm_year + 1900 + Year_Val;
Month := Tm_Val.tm_mon + 1;
Day := Tm_Val.tm_mday;
-- The Seconds value is a little complex. The localtime function
-- returns the integral number of seconds, which is what we want,
-- but we want to retain the fractional part from the original
-- Time value, since this is typically stored more accurately.
Seconds := Duration (Tm_Val.tm_hour * 3600 +
Tm_Val.tm_min * 60 +
Tm_Val.tm_sec)
+ Frac_Sec;
-- Note: the above expression is pretty horrible, one of these days
-- we should stop using time_of and do everything ourselves to avoid
-- these unnecessary divides and multiplies???.
-- The Year may still be out of range, since our entry test was
-- deliberately crude. Trying to make this entry test accurate is
-- tricky due to time zone adjustment issues affecting the exact
-- boundary. It is interesting to note that whether or not a given
-- Calendar.Time value gets Time_Error when split depends on the
-- current time zone setting.
if Year_Val not in Ada_Year_Min .. Ada_Year_Max then
raise Time_Error;
else
Year := Year_Val;
end if;
end Split;
-------------
-- Time_Of --
-------------
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0)
return Time
is
Result_Secs : aliased time_t;
TM_Val : aliased tm;
Int_Secs : constant Integer := Integer (Seconds);
Year_Val : Integer := Year;
Duration_Adjust : Duration := 0.0;
begin
-- The following checks are redundant with respect to the constraint
-- error checks that should normally be made on parameters, but we
-- decide to raise Constraint_Error in any case if bad values come
-- in (as a result of checks being off in the caller, or for other
-- erroneous or bounded error cases).
if not Year 'Valid
or else not Month 'Valid
or else not Day 'Valid
or else not Seconds'Valid
then
raise Constraint_Error;
end if;
-- Check for Day value too large (one might expect mktime to do this
-- check, as well as the basi checks we did with 'Valid, but it seems
-- that at least on some systems, this built-in check is too weak).
if Day > Days_In_Month (Month)
and then (Day /= 29 or Month /= 2 or Year mod 4 /= 0)
then
raise Time_Error;
end if;
TM_Val.tm_sec := Int_Secs mod 60;
TM_Val.tm_min := (Int_Secs / 60) mod 60;
TM_Val.tm_hour := (Int_Secs / 60) / 60;
TM_Val.tm_mday := Day;
TM_Val.tm_mon := Month - 1;
-- For the year, we have to adjust it to a year that Unix can handle.
-- We do this in four year steps, since the number of days in four
-- years is constant, so the timezone effect on the conversion from
-- local time to GMT is unaffected.
while Year_Val <= Unix_Year_Min loop
Year_Val := Year_Val + 4;
Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD;
end loop;
while Year_Val >= Unix_Year_Max loop
Year_Val := Year_Val - 4;
Duration_Adjust := Duration_Adjust + Seconds_In_4_YearsD;
end loop;
TM_Val.tm_year := Year_Val - 1900;
-- Since we do not have information on daylight savings,
-- rely on the default information.
TM_Val.tm_isdst := -1;
Result_Secs := mktime (TM_Val'Unchecked_Access);
-- That gives us the basic value in seconds. Two adjustments are
-- needed. First we must undo the year adjustment carried out above.
-- Second we put back the fraction seconds value since in general the
-- Day_Duration value we received has additional precision which we
-- do not want to lose in the constructed result.
return
Time (Duration (Result_Secs) +
Duration_Adjust +
(Seconds - Duration (Int_Secs)));
end Time_Of;
----------
-- Year --
----------
function Year (Date : Time) return Year_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DY;
end Year;
end Ada.Calendar;

119
gcc/ada/a-calend.ads Normal file
View File

@ -0,0 +1,119 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C A L E N D A R --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package Ada.Calendar is
type Time is private;
-- Declarations representing limits of allowed local time values. Note that
-- these do NOT constrain the possible stored values of time which may well
-- permit a larger range of times (this is explicitly allowed in Ada 95).
subtype Year_Number is Integer range 1901 .. 2099;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
function Clock return Time;
function Year (Date : Time) return Year_Number;
function Month (Date : Time) return Month_Number;
function Day (Date : Time) return Day_Number;
function Seconds (Date : Time) return Day_Duration;
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration);
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0)
return Time;
function "+" (Left : Time; Right : Duration) return Time;
function "+" (Left : Duration; Right : Time) return Time;
function "-" (Left : Time; Right : Duration) return Time;
function "-" (Left : Time; Right : Time) return Duration;
function "<" (Left, Right : Time) return Boolean;
function "<=" (Left, Right : Time) return Boolean;
function ">" (Left, Right : Time) return Boolean;
function ">=" (Left, Right : Time) return Boolean;
Time_Error : exception;
private
pragma Inline (Clock);
pragma Inline (Year);
pragma Inline (Month);
pragma Inline (Day);
pragma Inline ("+");
pragma Inline ("-");
pragma Inline ("<");
pragma Inline ("<=");
pragma Inline (">");
pragma Inline (">=");
-- Time is represented as a signed duration from the base point which is
-- what Unix calls the EPOCH (i.e. 12 midnight (24:00:00), Dec 31st, 1969,
-- or if you prefer 0:00:00 on Jan 1st, 1970). Since Ada allows dates
-- before this EPOCH value, the stored duration value may be negative.
-- The time value stored is typically a GMT value, as provided in standard
-- Unix environments. If this is the case then Split and Time_Of perform
-- required conversions to and from local times. The range of times that
-- can be stored in Time values depends on the declaration of the type
-- Duration, which must at least cover the required Ada range represented
-- by the declaration of Year_Number, but may be larger (we take full
-- advantage of the new permission in Ada 95 to store time values outside
-- the range that would be acceptable to Split). The Duration type is a
-- real value representing a time interval in seconds.
type Time is new Duration;
end Ada.Calendar;

585
gcc/ada/a-chahan.adb Normal file
View File

@ -0,0 +1,585 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C H A R A C T E R S . H A N D L I N G --
-- --
-- B o d y --
-- --
-- $Revision: 1.19 $
-- --
-- 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 Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
package body Ada.Characters.Handling is
------------------------------------
-- Character Classification Table --
------------------------------------
type Character_Flags is mod 256;
for Character_Flags'Size use 8;
Control : constant Character_Flags := 1;
Lower : constant Character_Flags := 2;
Upper : constant Character_Flags := 4;
Basic : constant Character_Flags := 8;
Hex_Digit : constant Character_Flags := 16;
Digit : constant Character_Flags := 32;
Special : constant Character_Flags := 64;
Letter : constant Character_Flags := Lower or Upper;
Alphanum : constant Character_Flags := Letter or Digit;
Graphic : constant Character_Flags := Alphanum or Special;
Char_Map : constant array (Character) of Character_Flags :=
(
NUL => Control,
SOH => Control,
STX => Control,
ETX => Control,
EOT => Control,
ENQ => Control,
ACK => Control,
BEL => Control,
BS => Control,
HT => Control,
LF => Control,
VT => Control,
FF => Control,
CR => Control,
SO => Control,
SI => Control,
DLE => Control,
DC1 => Control,
DC2 => Control,
DC3 => Control,
DC4 => Control,
NAK => Control,
SYN => Control,
ETB => Control,
CAN => Control,
EM => Control,
SUB => Control,
ESC => Control,
FS => Control,
GS => Control,
RS => Control,
US => Control,
Space => Special,
Exclamation => Special,
Quotation => Special,
Number_Sign => Special,
Dollar_Sign => Special,
Percent_Sign => Special,
Ampersand => Special,
Apostrophe => Special,
Left_Parenthesis => Special,
Right_Parenthesis => Special,
Asterisk => Special,
Plus_Sign => Special,
Comma => Special,
Hyphen => Special,
Full_Stop => Special,
Solidus => Special,
'0' .. '9' => Digit + Hex_Digit,
Colon => Special,
Semicolon => Special,
Less_Than_Sign => Special,
Equals_Sign => Special,
Greater_Than_Sign => Special,
Question => Special,
Commercial_At => Special,
'A' .. 'F' => Upper + Basic + Hex_Digit,
'G' .. 'Z' => Upper + Basic,
Left_Square_Bracket => Special,
Reverse_Solidus => Special,
Right_Square_Bracket => Special,
Circumflex => Special,
Low_Line => Special,
Grave => Special,
'a' .. 'f' => Lower + Basic + Hex_Digit,
'g' .. 'z' => Lower + Basic,
Left_Curly_Bracket => Special,
Vertical_Line => Special,
Right_Curly_Bracket => Special,
Tilde => Special,
DEL => Control,
Reserved_128 => Control,
Reserved_129 => Control,
BPH => Control,
NBH => Control,
Reserved_132 => Control,
NEL => Control,
SSA => Control,
ESA => Control,
HTS => Control,
HTJ => Control,
VTS => Control,
PLD => Control,
PLU => Control,
RI => Control,
SS2 => Control,
SS3 => Control,
DCS => Control,
PU1 => Control,
PU2 => Control,
STS => Control,
CCH => Control,
MW => Control,
SPA => Control,
EPA => Control,
SOS => Control,
Reserved_153 => Control,
SCI => Control,
CSI => Control,
ST => Control,
OSC => Control,
PM => Control,
APC => Control,
No_Break_Space => Special,
Inverted_Exclamation => Special,
Cent_Sign => Special,
Pound_Sign => Special,
Currency_Sign => Special,
Yen_Sign => Special,
Broken_Bar => Special,
Section_Sign => Special,
Diaeresis => Special,
Copyright_Sign => Special,
Feminine_Ordinal_Indicator => Special,
Left_Angle_Quotation => Special,
Not_Sign => Special,
Soft_Hyphen => Special,
Registered_Trade_Mark_Sign => Special,
Macron => Special,
Degree_Sign => Special,
Plus_Minus_Sign => Special,
Superscript_Two => Special,
Superscript_Three => Special,
Acute => Special,
Micro_Sign => Special,
Pilcrow_Sign => Special,
Middle_Dot => Special,
Cedilla => Special,
Superscript_One => Special,
Masculine_Ordinal_Indicator => Special,
Right_Angle_Quotation => Special,
Fraction_One_Quarter => Special,
Fraction_One_Half => Special,
Fraction_Three_Quarters => Special,
Inverted_Question => Special,
UC_A_Grave => Upper,
UC_A_Acute => Upper,
UC_A_Circumflex => Upper,
UC_A_Tilde => Upper,
UC_A_Diaeresis => Upper,
UC_A_Ring => Upper,
UC_AE_Diphthong => Upper + Basic,
UC_C_Cedilla => Upper,
UC_E_Grave => Upper,
UC_E_Acute => Upper,
UC_E_Circumflex => Upper,
UC_E_Diaeresis => Upper,
UC_I_Grave => Upper,
UC_I_Acute => Upper,
UC_I_Circumflex => Upper,
UC_I_Diaeresis => Upper,
UC_Icelandic_Eth => Upper + Basic,
UC_N_Tilde => Upper,
UC_O_Grave => Upper,
UC_O_Acute => Upper,
UC_O_Circumflex => Upper,
UC_O_Tilde => Upper,
UC_O_Diaeresis => Upper,
Multiplication_Sign => Special,
UC_O_Oblique_Stroke => Upper,
UC_U_Grave => Upper,
UC_U_Acute => Upper,
UC_U_Circumflex => Upper,
UC_U_Diaeresis => Upper,
UC_Y_Acute => Upper,
UC_Icelandic_Thorn => Upper + Basic,
LC_German_Sharp_S => Lower + Basic,
LC_A_Grave => Lower,
LC_A_Acute => Lower,
LC_A_Circumflex => Lower,
LC_A_Tilde => Lower,
LC_A_Diaeresis => Lower,
LC_A_Ring => Lower,
LC_AE_Diphthong => Lower + Basic,
LC_C_Cedilla => Lower,
LC_E_Grave => Lower,
LC_E_Acute => Lower,
LC_E_Circumflex => Lower,
LC_E_Diaeresis => Lower,
LC_I_Grave => Lower,
LC_I_Acute => Lower,
LC_I_Circumflex => Lower,
LC_I_Diaeresis => Lower,
LC_Icelandic_Eth => Lower + Basic,
LC_N_Tilde => Lower,
LC_O_Grave => Lower,
LC_O_Acute => Lower,
LC_O_Circumflex => Lower,
LC_O_Tilde => Lower,
LC_O_Diaeresis => Lower,
Division_Sign => Special,
LC_O_Oblique_Stroke => Lower,
LC_U_Grave => Lower,
LC_U_Acute => Lower,
LC_U_Circumflex => Lower,
LC_U_Diaeresis => Lower,
LC_Y_Acute => Lower,
LC_Icelandic_Thorn => Lower + Basic,
LC_Y_Diaeresis => Lower
);
---------------------
-- Is_Alphanumeric --
---------------------
function Is_Alphanumeric (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Alphanum) /= 0;
end Is_Alphanumeric;
--------------
-- Is_Basic --
--------------
function Is_Basic (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Basic) /= 0;
end Is_Basic;
------------------
-- Is_Character --
------------------
function Is_Character (Item : in Wide_Character) return Boolean is
begin
return Wide_Character'Pos (Item) < 256;
end Is_Character;
----------------
-- Is_Control --
----------------
function Is_Control (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Control) /= 0;
end Is_Control;
--------------
-- Is_Digit --
--------------
function Is_Digit (Item : in Character) return Boolean is
begin
return Item in '0' .. '9';
end Is_Digit;
----------------
-- Is_Graphic --
----------------
function Is_Graphic (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Graphic) /= 0;
end Is_Graphic;
--------------------------
-- Is_Hexadecimal_Digit --
--------------------------
function Is_Hexadecimal_Digit (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Hex_Digit) /= 0;
end Is_Hexadecimal_Digit;
----------------
-- Is_ISO_646 --
----------------
function Is_ISO_646 (Item : in Character) return Boolean is
begin
return Item in ISO_646;
end Is_ISO_646;
-- Note: much more efficient coding of the following function is possible
-- by testing several 16#80# bits in a complete word in a single operation
function Is_ISO_646 (Item : in String) return Boolean is
begin
for J in Item'Range loop
if Item (J) not in ISO_646 then
return False;
end if;
end loop;
return True;
end Is_ISO_646;
---------------
-- Is_Letter --
---------------
function Is_Letter (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Letter) /= 0;
end Is_Letter;
--------------
-- Is_Lower --
--------------
function Is_Lower (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Lower) /= 0;
end Is_Lower;
----------------
-- Is_Special --
----------------
function Is_Special (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Special) /= 0;
end Is_Special;
---------------
-- Is_String --
---------------
function Is_String (Item : in Wide_String) return Boolean is
begin
for J in Item'Range loop
if Wide_Character'Pos (Item (J)) >= 256 then
return False;
end if;
end loop;
return True;
end Is_String;
--------------
-- Is_Upper --
--------------
function Is_Upper (Item : in Character) return Boolean is
begin
return (Char_Map (Item) and Upper) /= 0;
end Is_Upper;
--------------
-- To_Basic --
--------------
function To_Basic (Item : in Character) return Character is
begin
return Value (Basic_Map, Item);
end To_Basic;
function To_Basic (Item : in String) return String is
Result : String (1 .. Item'Length);
begin
for J in Item'Range loop
Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J));
end loop;
return Result;
end To_Basic;
------------------
-- To_Character --
------------------
function To_Character
(Item : in Wide_Character;
Substitute : in Character := ' ')
return Character
is
begin
if Is_Character (Item) then
return Character'Val (Wide_Character'Pos (Item));
else
return Substitute;
end if;
end To_Character;
----------------
-- To_ISO_646 --
----------------
function To_ISO_646
(Item : in Character;
Substitute : in ISO_646 := ' ')
return ISO_646
is
begin
if Item in ISO_646 then
return Item;
else
return Substitute;
end if;
end To_ISO_646;
function To_ISO_646
(Item : in String;
Substitute : in ISO_646 := ' ')
return String
is
Result : String (1 .. Item'Length);
begin
for J in Item'Range loop
if Item (J) in ISO_646 then
Result (J - (Item'First - 1)) := Item (J);
else
Result (J - (Item'First - 1)) := Substitute;
end if;
end loop;
return Result;
end To_ISO_646;
--------------
-- To_Lower --
--------------
function To_Lower (Item : in Character) return Character is
begin
return Value (Lower_Case_Map, Item);
end To_Lower;
function To_Lower (Item : in String) return String is
Result : String (1 .. Item'Length);
begin
for J in Item'Range loop
Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J));
end loop;
return Result;
end To_Lower;
---------------
-- To_String --
---------------
function To_String
(Item : in Wide_String;
Substitute : in Character := ' ')
return String
is
Result : String (1 .. Item'Length);
begin
for J in Item'Range loop
Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute);
end loop;
return Result;
end To_String;
--------------
-- To_Upper --
--------------
function To_Upper
(Item : in Character)
return Character
is
begin
return Value (Upper_Case_Map, Item);
end To_Upper;
function To_Upper
(Item : in String)
return String
is
Result : String (1 .. Item'Length);
begin
for J in Item'Range loop
Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J));
end loop;
return Result;
end To_Upper;
-----------------------
-- To_Wide_Character --
-----------------------
function To_Wide_Character
(Item : in Character)
return Wide_Character
is
begin
return Wide_Character'Val (Character'Pos (Item));
end To_Wide_Character;
--------------------
-- To_Wide_String --
--------------------
function To_Wide_String
(Item : in String)
return Wide_String
is
Result : Wide_String (1 .. Item'Length);
begin
for J in Item'Range loop
Result (J - (Item'First - 1)) := To_Wide_Character (Item (J));
end loop;
return Result;
end To_Wide_String;
end Ada.Characters.Handling;

136
gcc/ada/a-chahan.ads Normal file
View File

@ -0,0 +1,136 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C H A R A C T E R S . H A N D L I N G --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package Ada.Characters.Handling is
pragma Preelaborate (Handling);
----------------------------------------
-- Character Classification Functions --
----------------------------------------
function Is_Control (Item : in Character) return Boolean;
function Is_Graphic (Item : in Character) return Boolean;
function Is_Letter (Item : in Character) return Boolean;
function Is_Lower (Item : in Character) return Boolean;
function Is_Upper (Item : in Character) return Boolean;
function Is_Basic (Item : in Character) return Boolean;
function Is_Digit (Item : in Character) return Boolean;
function Is_Decimal_Digit (Item : in Character) return Boolean
renames Is_Digit;
function Is_Hexadecimal_Digit (Item : in Character) return Boolean;
function Is_Alphanumeric (Item : in Character) return Boolean;
function Is_Special (Item : in Character) return Boolean;
---------------------------------------------------
-- Conversion Functions for Character and String --
---------------------------------------------------
function To_Lower (Item : in Character) return Character;
function To_Upper (Item : in Character) return Character;
function To_Basic (Item : in Character) return Character;
function To_Lower (Item : in String) return String;
function To_Upper (Item : in String) return String;
function To_Basic (Item : in String) return String;
----------------------------------------------------------------------
-- Classifications of and Conversions Between Character and ISO 646 --
----------------------------------------------------------------------
subtype ISO_646 is
Character range Character'Val (0) .. Character'Val (127);
function Is_ISO_646 (Item : in Character) return Boolean;
function Is_ISO_646 (Item : in String) return Boolean;
function To_ISO_646
(Item : in Character;
Substitute : in ISO_646 := ' ')
return ISO_646;
function To_ISO_646
(Item : in String;
Substitute : in ISO_646 := ' ')
return String;
------------------------------------------------------
-- Classifications of Wide_Character and Characters --
------------------------------------------------------
function Is_Character (Item : in Wide_Character) return Boolean;
function Is_String (Item : in Wide_String) return Boolean;
------------------------------------------------------
-- Conversions between Wide_Character and Character --
------------------------------------------------------
function To_Character
(Item : in Wide_Character;
Substitute : in Character := ' ')
return Character;
function To_String
(Item : in Wide_String;
Substitute : in Character := ' ')
return String;
function To_Wide_Character (Item : in Character) return Wide_Character;
function To_Wide_String (Item : in String) return Wide_String;
private
pragma Inline (Is_Control);
pragma Inline (Is_Graphic);
pragma Inline (Is_Letter);
pragma Inline (Is_Lower);
pragma Inline (Is_Upper);
pragma Inline (Is_Basic);
pragma Inline (Is_Digit);
pragma Inline (Is_Hexadecimal_Digit);
pragma Inline (Is_Alphanumeric);
pragma Inline (Is_Special);
pragma Inline (To_Lower);
pragma Inline (To_Upper);
pragma Inline (To_Basic);
pragma Inline (Is_ISO_646);
pragma Inline (Is_Character);
pragma Inline (To_Character);
pragma Inline (To_Wide_Character);
end Ada.Characters.Handling;

22
gcc/ada/a-charac.ads Normal file
View File

@ -0,0 +1,22 @@
-----------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C H A R A C T E R S --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.Characters is
pragma Pure (Characters);
end Ada.Characters;

297
gcc/ada/a-chlat1.ads Normal file
View File

@ -0,0 +1,297 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C H A R A C T E R S . L A T I N _ 1 --
-- --
-- S p e c --
-- --
-- $Revision: 1.13 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.Characters.Latin_1 is
pragma Pure (Latin_1);
------------------------
-- Control Characters --
------------------------
NUL : constant Character := Character'Val (0);
SOH : constant Character := Character'Val (1);
STX : constant Character := Character'Val (2);
ETX : constant Character := Character'Val (3);
EOT : constant Character := Character'Val (4);
ENQ : constant Character := Character'Val (5);
ACK : constant Character := Character'Val (6);
BEL : constant Character := Character'Val (7);
BS : constant Character := Character'Val (8);
HT : constant Character := Character'Val (9);
LF : constant Character := Character'Val (10);
VT : constant Character := Character'Val (11);
FF : constant Character := Character'Val (12);
CR : constant Character := Character'Val (13);
SO : constant Character := Character'Val (14);
SI : constant Character := Character'Val (15);
DLE : constant Character := Character'Val (16);
DC1 : constant Character := Character'Val (17);
DC2 : constant Character := Character'Val (18);
DC3 : constant Character := Character'Val (19);
DC4 : constant Character := Character'Val (20);
NAK : constant Character := Character'Val (21);
SYN : constant Character := Character'Val (22);
ETB : constant Character := Character'Val (23);
CAN : constant Character := Character'Val (24);
EM : constant Character := Character'Val (25);
SUB : constant Character := Character'Val (26);
ESC : constant Character := Character'Val (27);
FS : constant Character := Character'Val (28);
GS : constant Character := Character'Val (29);
RS : constant Character := Character'Val (30);
US : constant Character := Character'Val (31);
--------------------------------
-- ISO 646 Graphic Characters --
--------------------------------
Space : constant Character := ' '; -- Character'Val(32)
Exclamation : constant Character := '!'; -- Character'Val(33)
Quotation : constant Character := '"'; -- Character'Val(34)
Number_Sign : constant Character := '#'; -- Character'Val(35)
Dollar_Sign : constant Character := '$'; -- Character'Val(36)
Percent_Sign : constant Character := '%'; -- Character'Val(37)
Ampersand : constant Character := '&'; -- Character'Val(38)
Apostrophe : constant Character := '''; -- Character'Val(39)
Left_Parenthesis : constant Character := '('; -- Character'Val(40)
Right_Parenthesis : constant Character := ')'; -- Character'Val(41)
Asterisk : constant Character := '*'; -- Character'Val(42)
Plus_Sign : constant Character := '+'; -- Character'Val(43)
Comma : constant Character := ','; -- Character'Val(44)
Hyphen : constant Character := '-'; -- Character'Val(45)
Minus_Sign : Character renames Hyphen;
Full_Stop : constant Character := '.'; -- Character'Val(46)
Solidus : constant Character := '/'; -- Character'Val(47)
-- Decimal digits '0' though '9' are at positions 48 through 57
Colon : constant Character := ':'; -- Character'Val(58)
Semicolon : constant Character := ';'; -- Character'Val(59)
Less_Than_Sign : constant Character := '<'; -- Character'Val(60)
Equals_Sign : constant Character := '='; -- Character'Val(61)
Greater_Than_Sign : constant Character := '>'; -- Character'Val(62)
Question : constant Character := '?'; -- Character'Val(63)
Commercial_At : constant Character := '@'; -- Character'Val(64)
-- Letters 'A' through 'Z' are at positions 65 through 90
Left_Square_Bracket : constant Character := '['; -- Character'Val (91)
Reverse_Solidus : constant Character := '\'; -- Character'Val (92)
Right_Square_Bracket : constant Character := ']'; -- Character'Val (93)
Circumflex : constant Character := '^'; -- Character'Val (94)
Low_Line : constant Character := '_'; -- Character'Val (95)
Grave : constant Character := '`'; -- Character'Val (96)
LC_A : constant Character := 'a'; -- Character'Val (97)
LC_B : constant Character := 'b'; -- Character'Val (98)
LC_C : constant Character := 'c'; -- Character'Val (99)
LC_D : constant Character := 'd'; -- Character'Val (100)
LC_E : constant Character := 'e'; -- Character'Val (101)
LC_F : constant Character := 'f'; -- Character'Val (102)
LC_G : constant Character := 'g'; -- Character'Val (103)
LC_H : constant Character := 'h'; -- Character'Val (104)
LC_I : constant Character := 'i'; -- Character'Val (105)
LC_J : constant Character := 'j'; -- Character'Val (106)
LC_K : constant Character := 'k'; -- Character'Val (107)
LC_L : constant Character := 'l'; -- Character'Val (108)
LC_M : constant Character := 'm'; -- Character'Val (109)
LC_N : constant Character := 'n'; -- Character'Val (110)
LC_O : constant Character := 'o'; -- Character'Val (111)
LC_P : constant Character := 'p'; -- Character'Val (112)
LC_Q : constant Character := 'q'; -- Character'Val (113)
LC_R : constant Character := 'r'; -- Character'Val (114)
LC_S : constant Character := 's'; -- Character'Val (115)
LC_T : constant Character := 't'; -- Character'Val (116)
LC_U : constant Character := 'u'; -- Character'Val (117)
LC_V : constant Character := 'v'; -- Character'Val (118)
LC_W : constant Character := 'w'; -- Character'Val (119)
LC_X : constant Character := 'x'; -- Character'Val (120)
LC_Y : constant Character := 'y'; -- Character'Val (121)
LC_Z : constant Character := 'z'; -- Character'Val (122)
Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123)
Vertical_Line : constant Character := '|'; -- Character'Val (124)
Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125)
Tilde : constant Character := '~'; -- Character'Val (126)
DEL : constant Character := Character'Val (127);
---------------------------------
-- ISO 6429 Control Characters --
---------------------------------
IS4 : Character renames FS;
IS3 : Character renames GS;
IS2 : Character renames RS;
IS1 : Character renames US;
Reserved_128 : constant Character := Character'Val (128);
Reserved_129 : constant Character := Character'Val (129);
BPH : constant Character := Character'Val (130);
NBH : constant Character := Character'Val (131);
Reserved_132 : constant Character := Character'Val (132);
NEL : constant Character := Character'Val (133);
SSA : constant Character := Character'Val (134);
ESA : constant Character := Character'Val (135);
HTS : constant Character := Character'Val (136);
HTJ : constant Character := Character'Val (137);
VTS : constant Character := Character'Val (138);
PLD : constant Character := Character'Val (139);
PLU : constant Character := Character'Val (140);
RI : constant Character := Character'Val (141);
SS2 : constant Character := Character'Val (142);
SS3 : constant Character := Character'Val (143);
DCS : constant Character := Character'Val (144);
PU1 : constant Character := Character'Val (145);
PU2 : constant Character := Character'Val (146);
STS : constant Character := Character'Val (147);
CCH : constant Character := Character'Val (148);
MW : constant Character := Character'Val (149);
SPA : constant Character := Character'Val (150);
EPA : constant Character := Character'Val (151);
SOS : constant Character := Character'Val (152);
Reserved_153 : constant Character := Character'Val (153);
SCI : constant Character := Character'Val (154);
CSI : constant Character := Character'Val (155);
ST : constant Character := Character'Val (156);
OSC : constant Character := Character'Val (157);
PM : constant Character := Character'Val (158);
APC : constant Character := Character'Val (159);
------------------------------
-- Other Graphic Characters --
------------------------------
-- Character positions 160 (16#A0#) .. 175 (16#AF#)
No_Break_Space : constant Character := Character'Val (160);
NBSP : Character renames No_Break_Space;
Inverted_Exclamation : constant Character := Character'Val (161);
Cent_Sign : constant Character := Character'Val (162);
Pound_Sign : constant Character := Character'Val (163);
Currency_Sign : constant Character := Character'Val (164);
Yen_Sign : constant Character := Character'Val (165);
Broken_Bar : constant Character := Character'Val (166);
Section_Sign : constant Character := Character'Val (167);
Diaeresis : constant Character := Character'Val (168);
Copyright_Sign : constant Character := Character'Val (169);
Feminine_Ordinal_Indicator : constant Character := Character'Val (170);
Left_Angle_Quotation : constant Character := Character'Val (171);
Not_Sign : constant Character := Character'Val (172);
Soft_Hyphen : constant Character := Character'Val (173);
Registered_Trade_Mark_Sign : constant Character := Character'Val (174);
Macron : constant Character := Character'Val (175);
-- Character positions 176 (16#B0#) .. 191 (16#BF#)
Degree_Sign : constant Character := Character'Val (176);
Ring_Above : Character renames Degree_Sign;
Plus_Minus_Sign : constant Character := Character'Val (177);
Superscript_Two : constant Character := Character'Val (178);
Superscript_Three : constant Character := Character'Val (179);
Acute : constant Character := Character'Val (180);
Micro_Sign : constant Character := Character'Val (181);
Pilcrow_Sign : constant Character := Character'Val (182);
Paragraph_Sign : Character renames Pilcrow_Sign;
Middle_Dot : constant Character := Character'Val (183);
Cedilla : constant Character := Character'Val (184);
Superscript_One : constant Character := Character'Val (185);
Masculine_Ordinal_Indicator : constant Character := Character'Val (186);
Right_Angle_Quotation : constant Character := Character'Val (187);
Fraction_One_Quarter : constant Character := Character'Val (188);
Fraction_One_Half : constant Character := Character'Val (189);
Fraction_Three_Quarters : constant Character := Character'Val (190);
Inverted_Question : constant Character := Character'Val (191);
-- Character positions 192 (16#C0#) .. 207 (16#CF#)
UC_A_Grave : constant Character := Character'Val (192);
UC_A_Acute : constant Character := Character'Val (193);
UC_A_Circumflex : constant Character := Character'Val (194);
UC_A_Tilde : constant Character := Character'Val (195);
UC_A_Diaeresis : constant Character := Character'Val (196);
UC_A_Ring : constant Character := Character'Val (197);
UC_AE_Diphthong : constant Character := Character'Val (198);
UC_C_Cedilla : constant Character := Character'Val (199);
UC_E_Grave : constant Character := Character'Val (200);
UC_E_Acute : constant Character := Character'Val (201);
UC_E_Circumflex : constant Character := Character'Val (202);
UC_E_Diaeresis : constant Character := Character'Val (203);
UC_I_Grave : constant Character := Character'Val (204);
UC_I_Acute : constant Character := Character'Val (205);
UC_I_Circumflex : constant Character := Character'Val (206);
UC_I_Diaeresis : constant Character := Character'Val (207);
-- Character positions 208 (16#D0#) .. 223 (16#DF#)
UC_Icelandic_Eth : constant Character := Character'Val (208);
UC_N_Tilde : constant Character := Character'Val (209);
UC_O_Grave : constant Character := Character'Val (210);
UC_O_Acute : constant Character := Character'Val (211);
UC_O_Circumflex : constant Character := Character'Val (212);
UC_O_Tilde : constant Character := Character'Val (213);
UC_O_Diaeresis : constant Character := Character'Val (214);
Multiplication_Sign : constant Character := Character'Val (215);
UC_O_Oblique_Stroke : constant Character := Character'Val (216);
UC_U_Grave : constant Character := Character'Val (217);
UC_U_Acute : constant Character := Character'Val (218);
UC_U_Circumflex : constant Character := Character'Val (219);
UC_U_Diaeresis : constant Character := Character'Val (220);
UC_Y_Acute : constant Character := Character'Val (221);
UC_Icelandic_Thorn : constant Character := Character'Val (222);
LC_German_Sharp_S : constant Character := Character'Val (223);
-- Character positions 224 (16#E0#) .. 239 (16#EF#)
LC_A_Grave : constant Character := Character'Val (224);
LC_A_Acute : constant Character := Character'Val (225);
LC_A_Circumflex : constant Character := Character'Val (226);
LC_A_Tilde : constant Character := Character'Val (227);
LC_A_Diaeresis : constant Character := Character'Val (228);
LC_A_Ring : constant Character := Character'Val (229);
LC_AE_Diphthong : constant Character := Character'Val (230);
LC_C_Cedilla : constant Character := Character'Val (231);
LC_E_Grave : constant Character := Character'Val (232);
LC_E_Acute : constant Character := Character'Val (233);
LC_E_Circumflex : constant Character := Character'Val (234);
LC_E_Diaeresis : constant Character := Character'Val (235);
LC_I_Grave : constant Character := Character'Val (236);
LC_I_Acute : constant Character := Character'Val (237);
LC_I_Circumflex : constant Character := Character'Val (238);
LC_I_Diaeresis : constant Character := Character'Val (239);
-- Character positions 240 (16#F0#) .. 255 (16#FF)
LC_Icelandic_Eth : constant Character := Character'Val (240);
LC_N_Tilde : constant Character := Character'Val (241);
LC_O_Grave : constant Character := Character'Val (242);
LC_O_Acute : constant Character := Character'Val (243);
LC_O_Circumflex : constant Character := Character'Val (244);
LC_O_Tilde : constant Character := Character'Val (245);
LC_O_Diaeresis : constant Character := Character'Val (246);
Division_Sign : constant Character := Character'Val (247);
LC_O_Oblique_Stroke : constant Character := Character'Val (248);
LC_U_Grave : constant Character := Character'Val (249);
LC_U_Acute : constant Character := Character'Val (250);
LC_U_Circumflex : constant Character := Character'Val (251);
LC_U_Diaeresis : constant Character := Character'Val (252);
LC_Y_Acute : constant Character := Character'Val (253);
LC_Icelandic_Thorn : constant Character := Character'Val (254);
LC_Y_Diaeresis : constant Character := Character'Val (255);
end Ada.Characters.Latin_1;

75
gcc/ada/a-colien.adb Normal file
View File

@ -0,0 +1,75 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T --
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1996-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;
package body Ada.Command_Line.Environment is
-----------------------
-- Environment_Count --
-----------------------
function Environment_Count return Natural is
function Env_Count return Natural;
pragma Import (C, Env_Count, "__gnat_env_count");
begin
return Env_Count;
end Environment_Count;
-----------------------
-- Environment_Value --
-----------------------
function Environment_Value (Number : in Positive) return String is
procedure Fill_Env (E : System.Address; Env_Num : Integer);
pragma Import (C, Fill_Env, "__gnat_fill_env");
function Len_Env (Env_Num : Integer) return Integer;
pragma Import (C, Len_Env, "__gnat_len_env");
begin
if Number > Environment_Count then
raise Constraint_Error;
end if;
declare
Env : aliased String (1 .. Len_Env (Number - 1));
begin
Fill_Env (Env'Address, Number - 1);
return Env;
end;
end Environment_Value;
end Ada.Command_Line.Environment;

53
gcc/ada/a-colien.ads Normal file
View File

@ -0,0 +1,53 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1996-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). --
-- --
------------------------------------------------------------------------------
package Ada.Command_Line.Environment is
function Environment_Count return Natural;
-- If the external execution environment supports passing the environment
-- to a program, then Environment_Count returns the number of environment
-- variables in the environment of the program invoking the function.
-- Otherwise it returns 0. And that's a lot of environment.
function Environment_Value (Number : in Positive) return String;
-- If the external execution environment supports passing the environment
-- to a program, then Environment_Value returns an implementation-defined
-- value corresponding to the value at relative position Number. If Number
-- is outside the range 1 .. Environment_Count, then Constraint_Error is
-- propagated.
--
-- in GNAT: Corresponds to envp [n-1] (for n > 0) in C.
end Ada.Command_Line.Environment;

128
gcc/ada/a-colire.adb Normal file
View File

@ -0,0 +1,128 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . R E M O V E --
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 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. --
-- --
-- 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 Ada.Command_Line.Remove is
-----------------------
-- Local Subprograms --
-----------------------
procedure Initialize;
-- Initialize the Remove_Count and Remove_Args variables.
----------------
-- Initialize --
----------------
procedure Initialize is
begin
if Remove_Args = null then
Remove_Count := Argument_Count;
Remove_Args := new Arg_Nums (1 .. Argument_Count);
for J in Remove_Args'Range loop
Remove_Args (J) := J;
end loop;
end if;
end Initialize;
---------------------
-- Remove_Argument --
---------------------
procedure Remove_Argument (Number : in Positive) is
begin
Initialize;
if Number > Remove_Count then
raise Constraint_Error;
end if;
Remove_Count := Remove_Count - 1;
for J in Number .. Remove_Count loop
Remove_Args (J) := Remove_Args (J + 1);
end loop;
end Remove_Argument;
procedure Remove_Argument (Argument : String) is
begin
for J in reverse 1 .. Argument_Count loop
if Argument = Ada.Command_Line.Argument (J) then
Remove_Argument (J);
end if;
end loop;
end Remove_Argument;
----------------------
-- Remove_Arguments --
----------------------
procedure Remove_Arguments (From : Positive; To : Natural) is
begin
Initialize;
if From > Remove_Count
or else To > Remove_Count
then
raise Constraint_Error;
end if;
if To >= From then
Remove_Count := Remove_Count - (To - From + 1);
for J in From .. Remove_Count loop
Remove_Args (J) := Remove_Args (J + (To - From + 1));
end loop;
end if;
end Remove_Arguments;
procedure Remove_Arguments (Argument_Prefix : String) is
begin
for J in reverse 1 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
begin
if Arg'Length >= Argument_Prefix'Length
and then Arg (1 .. Argument_Prefix'Length) = Argument_Prefix
then
Remove_Argument (J);
end if;
end;
end loop;
end Remove_Arguments;
end Ada.Command_Line.Remove;

83
gcc/ada/a-colire.ads Normal file
View File

@ -0,0 +1,83 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E . R E M O V E --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 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. --
-- --
-- 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 is intended to be used in conjunction with its parent unit,
-- Ada.Command_Line. It provides facilities for logically removing arguments
-- from the command line, so that subsequent calls to Argument_Count and
-- Argument will reflect the removals.
-- For example, if the original command line has three arguments A B C, so
-- that Argument_Count is initially three, then after removing B, the second
-- argument, Argument_Count will be 2, and Argument (2) will return C.
package Ada.Command_Line.Remove is
pragma Preelaborate (Remove);
procedure Remove_Argument (Number : in Positive);
-- Removes the argument identified by Number, which must be in the
-- range 1 .. Argument_Count (i.e. an in range argument number which
-- reflects removals). If Number is out of range Constraint_Error
-- will be raised.
--
-- Note: the numbering of arguments greater than Number is affected
-- by the call. If you need a loop through the arguments, removing
-- some as you go, run the loop in reverse to avoid confusion from
-- this renumbering:
--
-- for J in reverse 1 .. Argument_Count loop
-- if Should_Remove (Arguments (J)) then
-- Remove_Argument (J);
-- end if;
-- end loop;
--
-- Reversing the loop in this manner avoids the confusion.
procedure Remove_Arguments (From : Positive; To : Natural);
-- Removes arguments in the given From..To range. From must be in the
-- range 1 .. Argument_Count and To in the range 0 .. Argument_Count.
-- Constraint_Error is raised if either argument is out of range. If
-- To is less than From, then the call has no effect.
procedure Remove_Argument (Argument : String);
-- Removes the argument which matches the given string Argument. Has
-- no effect if no argument matches the string. If more than one
-- argument matches the string, all are removed.
procedure Remove_Arguments (Argument_Prefix : String);
-- Removes all arguments whose prefix matches Argument_Prefix. Has
-- no effect if no argument matches the string. For example a call
-- to Remove_Arguments ("--") removes all arguments starting with --.
end Ada.Command_Line.Remove;

100
gcc/ada/a-comlin.adb Normal file
View File

@ -0,0 +1,100 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E --
-- --
-- B o d y --
-- --
-- $Revision: 1.12 $
-- --
-- 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;
package body Ada.Command_Line is
function Arg_Count return Natural;
pragma Import (C, Arg_Count, "__gnat_arg_count");
procedure Fill_Arg (A : System.Address; Arg_Num : Integer);
pragma Import (C, Fill_Arg, "__gnat_fill_arg");
function Len_Arg (Arg_Num : Integer) return Integer;
pragma Import (C, Len_Arg, "__gnat_len_arg");
--------------
-- Argument --
--------------
function Argument (Number : in Positive) return String is
Num : Positive;
begin
if Number > Argument_Count then
raise Constraint_Error;
end if;
if Remove_Args = null then
Num := Number;
else
Num := Remove_Args (Number);
end if;
declare
Arg : aliased String (1 .. Len_Arg (Num));
begin
Fill_Arg (Arg'Address, Num);
return Arg;
end;
end Argument;
--------------------
-- Argument_Count --
--------------------
function Argument_Count return Natural is
begin
if Remove_Args = null then
return Arg_Count - 1;
else
return Remove_Count;
end if;
end Argument_Count;
------------------
-- Command_Name --
------------------
function Command_Name return String is
Arg : aliased String (1 .. Len_Arg (0));
begin
Fill_Arg (Arg'Address, 0);
return Arg;
end Command_Name;
end Ada.Command_Line;

103
gcc/ada/a-comlin.ads Normal file
View File

@ -0,0 +1,103 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C O M M A N D _ L I N E --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package Ada.Command_Line is
pragma Preelaborate (Command_Line);
function Argument_Count return Natural;
-- If the external execution environment supports passing arguments to a
-- program, then Argument_Count returns the number of arguments passed to
-- the program invoking the function. Otherwise it return 0.
--
-- In GNAT: Corresponds to (argc - 1) in C.
function Argument (Number : Positive) return String;
-- If the external execution environment supports passing arguments to
-- a program, then Argument returns an implementation-defined value
-- corresponding to the argument at relative position Number. If Number
-- is outside the range 1 .. Argument_Count, then Constraint_Error is
-- propagated.
--
-- in GNAT: Corresponds to argv [n] (for n > 0) in C.
function Command_Name return String;
-- If the external execution environment supports passing arguments to
-- a program, then Command_Name returns an implementation-defined value
-- corresponding to the name of the command invoking the program.
-- Otherwise Command_Name returns the null string.
--
-- in GNAT: Corresponds to argv [0] in C.
type Exit_Status is new Integer;
Success : constant Exit_Status;
Failure : constant Exit_Status;
procedure Set_Exit_Status (Code : Exit_Status);
private
Success : constant Exit_Status := 0;
Failure : constant Exit_Status := 1;
-- The following locations support the operation of the package
-- Ada.Command_Line_Remove, whih provides facilities for logically
-- removing arguments from the command line. If one of the remove
-- procedures is called in this unit, then Remove_Args/Remove_Count
-- are set to indicate which arguments are removed. If no such calls
-- have been made, then Remove_Args is null.
Remove_Count : Natural;
-- Number of arguments reflecting removals. Not defined unless
-- Remove_Args is non-null.
type Arg_Nums is array (Positive range <>) of Positive;
type Arg_Nums_Ptr is access Arg_Nums;
-- An array that maps logical argument numbers (reflecting removal)
-- to physical argument numbers (e.g. if the first argument has been
-- removed, but not the second, then Arg_Nums (1) will be set to 2.
Remove_Args : Arg_Nums_Ptr := null;
-- Left set to null if no remove calls have been made, otherwise set
-- to point to an appropriate mapping array. Only the first Remove_Count
-- elements are relevant.
pragma Import (C, Set_Exit_Status, "__gnat_set_exit_status");
end Ada.Command_Line;

326
gcc/ada/a-cwila1.ads Normal file
View File

@ -0,0 +1,326 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 1 --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $
-- --
-- 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. --
-- --
-- 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 definitions analogous to those in the RM defined
-- package Ada.Characters.Latin_1 except that the type of the constants
-- is Wide_Character instead of Character. The provision of this package
-- is in accordance with the implementation permission in RM (A.3.3(27)).
package Ada.Characters.Wide_Latin_1 is
pragma Pure (Wide_Latin_1);
------------------------
-- Control Characters --
------------------------
NUL : constant Wide_Character := Wide_Character'Val (0);
SOH : constant Wide_Character := Wide_Character'Val (1);
STX : constant Wide_Character := Wide_Character'Val (2);
ETX : constant Wide_Character := Wide_Character'Val (3);
EOT : constant Wide_Character := Wide_Character'Val (4);
ENQ : constant Wide_Character := Wide_Character'Val (5);
ACK : constant Wide_Character := Wide_Character'Val (6);
BEL : constant Wide_Character := Wide_Character'Val (7);
BS : constant Wide_Character := Wide_Character'Val (8);
HT : constant Wide_Character := Wide_Character'Val (9);
LF : constant Wide_Character := Wide_Character'Val (10);
VT : constant Wide_Character := Wide_Character'Val (11);
FF : constant Wide_Character := Wide_Character'Val (12);
CR : constant Wide_Character := Wide_Character'Val (13);
SO : constant Wide_Character := Wide_Character'Val (14);
SI : constant Wide_Character := Wide_Character'Val (15);
DLE : constant Wide_Character := Wide_Character'Val (16);
DC1 : constant Wide_Character := Wide_Character'Val (17);
DC2 : constant Wide_Character := Wide_Character'Val (18);
DC3 : constant Wide_Character := Wide_Character'Val (19);
DC4 : constant Wide_Character := Wide_Character'Val (20);
NAK : constant Wide_Character := Wide_Character'Val (21);
SYN : constant Wide_Character := Wide_Character'Val (22);
ETB : constant Wide_Character := Wide_Character'Val (23);
CAN : constant Wide_Character := Wide_Character'Val (24);
EM : constant Wide_Character := Wide_Character'Val (25);
SUB : constant Wide_Character := Wide_Character'Val (26);
ESC : constant Wide_Character := Wide_Character'Val (27);
FS : constant Wide_Character := Wide_Character'Val (28);
GS : constant Wide_Character := Wide_Character'Val (29);
RS : constant Wide_Character := Wide_Character'Val (30);
US : constant Wide_Character := Wide_Character'Val (31);
-------------------------------------
-- ISO 646 Graphic Wide_Characters --
-------------------------------------
Space : constant Wide_Character := ' '; -- WC'Val(32)
Exclamation : constant Wide_Character := '!'; -- WC'Val(33)
Quotation : constant Wide_Character := '"'; -- WC'Val(34)
Number_Sign : constant Wide_Character := '#'; -- WC'Val(35)
Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36)
Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37)
Ampersand : constant Wide_Character := '&'; -- WC'Val(38)
Apostrophe : constant Wide_Character := '''; -- WC'Val(39)
Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40)
Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41)
Asterisk : constant Wide_Character := '*'; -- WC'Val(42)
Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43)
Comma : constant Wide_Character := ','; -- WC'Val(44)
Hyphen : constant Wide_Character := '-'; -- WC'Val(45)
Minus_Sign : Wide_Character renames Hyphen;
Full_Stop : constant Wide_Character := '.'; -- WC'Val(46)
Solidus : constant Wide_Character := '/'; -- WC'Val(47)
-- Decimal digits '0' though '9' are at positions 48 through 57
Colon : constant Wide_Character := ':'; -- WC'Val(58)
Semicolon : constant Wide_Character := ';'; -- WC'Val(59)
Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60)
Equals_Sign : constant Wide_Character := '='; -- WC'Val(61)
Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62)
Question : constant Wide_Character := '?'; -- WC'Val(63)
Commercial_At : constant Wide_Character := '@'; -- WC'Val(64)
-- Letters 'A' through 'Z' are at positions 65 through 90
Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91)
Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92)
Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93)
Circumflex : constant Wide_Character := '^'; -- WC'Val (94)
Low_Line : constant Wide_Character := '_'; -- WC'Val (95)
Grave : constant Wide_Character := '`'; -- WC'Val (96)
LC_A : constant Wide_Character := 'a'; -- WC'Val (97)
LC_B : constant Wide_Character := 'b'; -- WC'Val (98)
LC_C : constant Wide_Character := 'c'; -- WC'Val (99)
LC_D : constant Wide_Character := 'd'; -- WC'Val (100)
LC_E : constant Wide_Character := 'e'; -- WC'Val (101)
LC_F : constant Wide_Character := 'f'; -- WC'Val (102)
LC_G : constant Wide_Character := 'g'; -- WC'Val (103)
LC_H : constant Wide_Character := 'h'; -- WC'Val (104)
LC_I : constant Wide_Character := 'i'; -- WC'Val (105)
LC_J : constant Wide_Character := 'j'; -- WC'Val (106)
LC_K : constant Wide_Character := 'k'; -- WC'Val (107)
LC_L : constant Wide_Character := 'l'; -- WC'Val (108)
LC_M : constant Wide_Character := 'm'; -- WC'Val (109)
LC_N : constant Wide_Character := 'n'; -- WC'Val (110)
LC_O : constant Wide_Character := 'o'; -- WC'Val (111)
LC_P : constant Wide_Character := 'p'; -- WC'Val (112)
LC_Q : constant Wide_Character := 'q'; -- WC'Val (113)
LC_R : constant Wide_Character := 'r'; -- WC'Val (114)
LC_S : constant Wide_Character := 's'; -- WC'Val (115)
LC_T : constant Wide_Character := 't'; -- WC'Val (116)
LC_U : constant Wide_Character := 'u'; -- WC'Val (117)
LC_V : constant Wide_Character := 'v'; -- WC'Val (118)
LC_W : constant Wide_Character := 'w'; -- WC'Val (119)
LC_X : constant Wide_Character := 'x'; -- WC'Val (120)
LC_Y : constant Wide_Character := 'y'; -- WC'Val (121)
LC_Z : constant Wide_Character := 'z'; -- WC'Val (122)
Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123)
Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124)
Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125)
Tilde : constant Wide_Character := '~'; -- WC'Val (126)
DEL : constant Wide_Character := Wide_Character'Val (127);
--------------------------------------
-- ISO 6429 Control Wide_Characters --
--------------------------------------
IS4 : Wide_Character renames FS;
IS3 : Wide_Character renames GS;
IS2 : Wide_Character renames RS;
IS1 : Wide_Character renames US;
Reserved_128 : constant Wide_Character := Wide_Character'Val (128);
Reserved_129 : constant Wide_Character := Wide_Character'Val (129);
BPH : constant Wide_Character := Wide_Character'Val (130);
NBH : constant Wide_Character := Wide_Character'Val (131);
Reserved_132 : constant Wide_Character := Wide_Character'Val (132);
NEL : constant Wide_Character := Wide_Character'Val (133);
SSA : constant Wide_Character := Wide_Character'Val (134);
ESA : constant Wide_Character := Wide_Character'Val (135);
HTS : constant Wide_Character := Wide_Character'Val (136);
HTJ : constant Wide_Character := Wide_Character'Val (137);
VTS : constant Wide_Character := Wide_Character'Val (138);
PLD : constant Wide_Character := Wide_Character'Val (139);
PLU : constant Wide_Character := Wide_Character'Val (140);
RI : constant Wide_Character := Wide_Character'Val (141);
SS2 : constant Wide_Character := Wide_Character'Val (142);
SS3 : constant Wide_Character := Wide_Character'Val (143);
DCS : constant Wide_Character := Wide_Character'Val (144);
PU1 : constant Wide_Character := Wide_Character'Val (145);
PU2 : constant Wide_Character := Wide_Character'Val (146);
STS : constant Wide_Character := Wide_Character'Val (147);
CCH : constant Wide_Character := Wide_Character'Val (148);
MW : constant Wide_Character := Wide_Character'Val (149);
SPA : constant Wide_Character := Wide_Character'Val (150);
EPA : constant Wide_Character := Wide_Character'Val (151);
SOS : constant Wide_Character := Wide_Character'Val (152);
Reserved_153 : constant Wide_Character := Wide_Character'Val (153);
SCI : constant Wide_Character := Wide_Character'Val (154);
CSI : constant Wide_Character := Wide_Character'Val (155);
ST : constant Wide_Character := Wide_Character'Val (156);
OSC : constant Wide_Character := Wide_Character'Val (157);
PM : constant Wide_Character := Wide_Character'Val (158);
APC : constant Wide_Character := Wide_Character'Val (159);
-----------------------------------
-- Other Graphic Wide_Characters --
-----------------------------------
-- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#)
No_Break_Space : constant Wide_Character := Wide_Character'Val (160);
NBSP : Wide_Character renames No_Break_Space;
Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161);
Cent_Sign : constant Wide_Character := Wide_Character'Val (162);
Pound_Sign : constant Wide_Character := Wide_Character'Val (163);
Currency_Sign : constant Wide_Character := Wide_Character'Val (164);
Yen_Sign : constant Wide_Character := Wide_Character'Val (165);
Broken_Bar : constant Wide_Character := Wide_Character'Val (166);
Section_Sign : constant Wide_Character := Wide_Character'Val (167);
Diaeresis : constant Wide_Character := Wide_Character'Val (168);
Copyright_Sign : constant Wide_Character := Wide_Character'Val (169);
Feminine_Ordinal_Indicator
: constant Wide_Character := Wide_Character'Val (170);
Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171);
Not_Sign : constant Wide_Character := Wide_Character'Val (172);
Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173);
Registered_Trade_Mark_Sign
: constant Wide_Character := Wide_Character'Val (174);
Macron : constant Wide_Character := Wide_Character'Val (175);
-- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#)
Degree_Sign : constant Wide_Character := Wide_Character'Val (176);
Ring_Above : Wide_Character renames Degree_Sign;
Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177);
Superscript_Two : constant Wide_Character := Wide_Character'Val (178);
Superscript_Three : constant Wide_Character := Wide_Character'Val (179);
Acute : constant Wide_Character := Wide_Character'Val (180);
Micro_Sign : constant Wide_Character := Wide_Character'Val (181);
Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182);
Paragraph_Sign : Wide_Character renames Pilcrow_Sign;
Middle_Dot : constant Wide_Character := Wide_Character'Val (183);
Cedilla : constant Wide_Character := Wide_Character'Val (184);
Superscript_One : constant Wide_Character := Wide_Character'Val (185);
Masculine_Ordinal_Indicator
: constant Wide_Character := Wide_Character'Val (186);
Right_Angle_Quotation
: constant Wide_Character := Wide_Character'Val (187);
Fraction_One_Quarter : constant Wide_Character := Wide_Character'Val (188);
Fraction_One_Half : constant Wide_Character := Wide_Character'Val (189);
Fraction_Three_Quarters
: constant Wide_Character := Wide_Character'Val (190);
Inverted_Question : constant Wide_Character := Wide_Character'Val (191);
-- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#)
UC_A_Grave : constant Wide_Character := Wide_Character'Val (192);
UC_A_Acute : constant Wide_Character := Wide_Character'Val (193);
UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194);
UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195);
UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196);
UC_A_Ring : constant Wide_Character := Wide_Character'Val (197);
UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198);
UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199);
UC_E_Grave : constant Wide_Character := Wide_Character'Val (200);
UC_E_Acute : constant Wide_Character := Wide_Character'Val (201);
UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202);
UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203);
UC_I_Grave : constant Wide_Character := Wide_Character'Val (204);
UC_I_Acute : constant Wide_Character := Wide_Character'Val (205);
UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206);
UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207);
-- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#)
UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208);
UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209);
UC_O_Grave : constant Wide_Character := Wide_Character'Val (210);
UC_O_Acute : constant Wide_Character := Wide_Character'Val (211);
UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212);
UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213);
UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214);
Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215);
UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216);
UC_U_Grave : constant Wide_Character := Wide_Character'Val (217);
UC_U_Acute : constant Wide_Character := Wide_Character'Val (218);
UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219);
UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220);
UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221);
UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222);
LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223);
-- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#)
LC_A_Grave : constant Wide_Character := Wide_Character'Val (224);
LC_A_Acute : constant Wide_Character := Wide_Character'Val (225);
LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226);
LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227);
LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228);
LC_A_Ring : constant Wide_Character := Wide_Character'Val (229);
LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230);
LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231);
LC_E_Grave : constant Wide_Character := Wide_Character'Val (232);
LC_E_Acute : constant Wide_Character := Wide_Character'Val (233);
LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234);
LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235);
LC_I_Grave : constant Wide_Character := Wide_Character'Val (236);
LC_I_Acute : constant Wide_Character := Wide_Character'Val (237);
LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238);
LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239);
-- Wide_Character positions 240 (16#F0#) .. 255 (16#FF)
LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240);
LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241);
LC_O_Grave : constant Wide_Character := Wide_Character'Val (242);
LC_O_Acute : constant Wide_Character := Wide_Character'Val (243);
LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244);
LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245);
LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246);
Division_Sign : constant Wide_Character := Wide_Character'Val (247);
LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248);
LC_U_Grave : constant Wide_Character := Wide_Character'Val (249);
LC_U_Acute : constant Wide_Character := Wide_Character'Val (250);
LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251);
LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252);
LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253);
LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254);
LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255);
end Ada.Characters.Wide_Latin_1;

64
gcc/ada/a-decima.adb Normal file
View File

@ -0,0 +1,64 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . D E C I M A L --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- 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. --
-- --
-- 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 Ada.Decimal is
------------
-- Divide --
------------
procedure Divide
(Dividend : in Dividend_Type;
Divisor : in Divisor_Type;
Quotient : out Quotient_Type;
Remainder : out Remainder_Type)
is
-- We have a nested procedure that is the actual intrinsic divide.
-- This is required because in the current RM, Divide itself does
-- not have convention Intrinsic.
procedure Divide
(Dividend : in Dividend_Type;
Divisor : in Divisor_Type;
Quotient : out Quotient_Type;
Remainder : out Remainder_Type);
pragma Import (Intrinsic, Divide);
begin
Divide (Dividend, Divisor, Quotient, Remainder);
end Divide;
end Ada.Decimal;

71
gcc/ada/a-decima.ads Normal file
View File

@ -0,0 +1,71 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . D E C I M A L --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package Ada.Decimal is
pragma Pure (Decimal);
-- The compiler makes a number of assumptions based on the following five
-- constants (e.g. there is an assumption that decimal values can always
-- be represented in 64-bit signed binary form), so code modifications are
-- required to increase these constants.
Max_Scale : constant := +18;
Min_Scale : constant := -18;
Min_Delta : constant := 1.0E-18;
Max_Delta : constant := 1.0E+18;
Max_Decimal_Digits : constant := 18;
generic
type Dividend_Type is delta <> digits <>;
type Divisor_Type is delta <> digits <>;
type Quotient_Type is delta <> digits <>;
type Remainder_Type is delta <> digits <>;
procedure Divide
(Dividend : in Dividend_Type;
Divisor : in Divisor_Type;
Quotient : out Quotient_Type;
Remainder : out Remainder_Type);
private
pragma Inline (Divide);
end Ada.Decimal;

88
gcc/ada/a-diocst.adb Normal file
View File

@ -0,0 +1,88 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . D I R E C T _ I O . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1992-1998 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 Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO;
with System.File_Control_Block;
with System.Direct_IO;
with Unchecked_Conversion;
package body Ada.Direct_IO.C_Streams is
package FIO renames System.File_IO;
package FCB renames System.File_Control_Block;
package DIO renames System.Direct_IO;
subtype AP is FCB.AFCB_Ptr;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
--------------
-- C_Stream --
--------------
function C_Stream (F : File_Type) return FILEs is
begin
FIO.Check_File_Open (AP (F));
return F.Stream;
end C_Stream;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in FILEs;
Form : in String := "")
is
File_Control_Block : DIO.Direct_AFCB;
begin
FIO.Open (File_Ptr => AP (File),
Dummy_FCB => File_Control_Block,
Mode => To_FCB (Mode),
Name => "",
Form => Form,
Amethod => 'D',
Creat => False,
Text => False,
C_Stream => C_Stream);
File.Bytes := Bytes;
end Open;
end Ada.Direct_IO.C_Streams;

57
gcc/ada/a-diocst.ads Normal file
View File

@ -0,0 +1,57 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . D I R E C T _ I O . C _ S T R E A M S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- 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. --
-- --
-- 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 between Ada.Direct_IO and the
-- C streams. This allows sharing of a stream between Ada and C or C++,
-- as well as allowing the Ada program to operate directly on the stream.
with Interfaces.C_Streams;
generic
package Ada.Direct_IO.C_Streams is
package ICS renames Interfaces.C_Streams;
function C_Stream (F : File_Type) return ICS.FILEs;
-- Obtain stream from existing open file
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in ICS.FILEs;
Form : in String := "");
-- Create new file from existing stream
end Ada.Direct_IO.C_Streams;

273
gcc/ada/a-direio.adb Normal file
View File

@ -0,0 +1,273 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . D I R E C T _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.22 $ --
-- --
-- Copyright (C) 1992-1998 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 is the generic template for Direct_IO, i.e. the code that gets
-- duplicated. We absolutely minimize this code by either calling routines
-- in System.File_IO (for common file functions), or in System.Direct_IO
-- (for specialized Direct_IO functions)
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
with System.File_Control_Block;
with System.File_IO;
with System.Direct_IO;
with System.Storage_Elements;
with Unchecked_Conversion;
use type System.Direct_IO.Count;
package body Ada.Direct_IO is
Zeroes : System.Storage_Elements.Storage_Array :=
(1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0);
-- Buffer used to fill out partial records.
package FCB renames System.File_Control_Block;
package FIO renames System.File_IO;
package DIO renames System.Direct_IO;
SU : constant := System.Storage_Unit;
subtype AP is FCB.AFCB_Ptr;
subtype FP is DIO.File_Type;
subtype DCount is DIO.Count;
subtype DPCount is DIO.Positive_Count;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
-----------
-- Close --
-----------
procedure Close (File : in out File_Type) is
begin
FIO.Close (AP (File));
end Close;
------------
-- Create --
------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Inout_File;
Name : in String := "";
Form : in String := "")
is
begin
DIO.Create (FP (File), To_FCB (Mode), Name, Form);
File.Bytes := Bytes;
end Create;
------------
-- Delete --
------------
procedure Delete (File : in out File_Type) is
begin
FIO.Delete (AP (File));
end Delete;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : in File_Type) return Boolean is
begin
return DIO.End_Of_File (FP (File));
end End_Of_File;
----------
-- Form --
----------
function Form (File : in File_Type) return String is
begin
return FIO.Form (AP (File));
end Form;
-----------
-- Index --
-----------
function Index (File : in File_Type) return Positive_Count is
begin
return Positive_Count (DIO.Index (FP (File)));
end Index;
-------------
-- Is_Open --
-------------
function Is_Open (File : in File_Type) return Boolean is
begin
return FIO.Is_Open (AP (File));
end Is_Open;
----------
-- Mode --
----------
function Mode (File : in File_Type) return File_Mode is
begin
return To_DIO (FIO.Mode (AP (File)));
end Mode;
----------
-- Name --
----------
function Name (File : in File_Type) return String is
begin
return FIO.Name (AP (File));
end Name;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "")
is
begin
DIO.Open (FP (File), To_FCB (Mode), Name, Form);
File.Bytes := Bytes;
end Open;
----------
-- Read --
----------
procedure Read
(File : in File_Type;
Item : out Element_Type;
From : in Positive_Count)
is
begin
-- For a non-constrained variant record type, we read into an
-- intermediate buffer, since we may have the case of discriminated
-- records where a discriminant check is required, and we may need
-- to assign only part of the record buffer originally written
if not Element_Type'Constrained then
declare
Buf : Element_Type;
begin
DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From));
Item := Buf;
end;
-- In the normal case, we can read straight into the buffer
else
DIO.Read (FP (File), Item'Address, Bytes, DPCount (From));
end if;
end Read;
procedure Read (File : in File_Type; Item : out Element_Type) is
begin
-- Same processing for unconstrained case as above
if not Element_Type'Constrained then
declare
Buf : Element_Type;
begin
DIO.Read (FP (File), Buf'Address, Bytes);
Item := Buf;
end;
else
DIO.Read (FP (File), Item'Address, Bytes);
end if;
end Read;
-----------
-- Reset --
-----------
procedure Reset (File : in out File_Type; Mode : in File_Mode) is
begin
DIO.Reset (FP (File), To_FCB (Mode));
end Reset;
procedure Reset (File : in out File_Type) is
begin
DIO.Reset (FP (File));
end Reset;
---------------
-- Set_Index --
---------------
procedure Set_Index (File : in File_Type; To : in Positive_Count) is
begin
DIO.Set_Index (FP (File), DPCount (To));
end Set_Index;
----------
-- Size --
----------
function Size (File : in File_Type) return Count is
begin
return Count (DIO.Size (FP (File)));
end Size;
-----------
-- Write --
-----------
procedure Write
(File : in File_Type;
Item : in Element_Type;
To : in Positive_Count)
is
begin
DIO.Set_Index (FP (File), DPCount (To));
DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes);
end Write;
procedure Write (File : in File_Type; Item : in Element_Type) is
begin
DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes);
end Write;
end Ada.Direct_IO;

158
gcc/ada/a-direio.ads Normal file
View File

@ -0,0 +1,158 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . D I R E C T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.19 $
-- --
-- Copyright (C) 1992-1999 Free Software Foundation, 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.IO_Exceptions;
with System.Direct_IO;
with Interfaces.C_Streams;
generic
type Element_Type is private;
package Ada.Direct_IO is
type File_Type is limited private;
type File_Mode is (In_File, Inout_File, Out_File);
-- The following representation clause allows the use of unchecked
-- conversion for rapid translation between the File_Mode type
-- used in this package and System.File_IO.
for File_Mode use
(In_File => 0, -- System.File_IO.File_Mode'Pos (In_File)
Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File);
Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File)
type Count is range 0 .. System.Direct_IO.Count'Last;
subtype Positive_Count is Count range 1 .. Count'Last;
---------------------
-- File Management --
---------------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Inout_File;
Name : in String := "";
Form : in String := "");
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : in File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : in File_Type) return File_Mode;
function Name (File : in File_Type) return String;
function Form (File : in File_Type) return String;
function Is_Open (File : in File_Type) return Boolean;
---------------------------------
-- Input and Output Operations --
---------------------------------
procedure Read
(File : in File_Type;
Item : out Element_Type;
From : in Positive_Count);
procedure Read
(File : in File_Type;
Item : out Element_Type);
procedure Write
(File : in File_Type;
Item : in Element_Type;
To : in Positive_Count);
procedure Write
(File : in File_Type;
Item : in Element_Type);
procedure Set_Index (File : in File_Type; To : in Positive_Count);
function Index (File : in File_Type) return Positive_Count;
function Size (File : in File_Type) return Count;
function End_Of_File (File : in File_Type) return Boolean;
----------------
-- Exceptions --
----------------
Status_Error : exception renames IO_Exceptions.Status_Error;
Mode_Error : exception renames IO_Exceptions.Mode_Error;
Name_Error : exception renames IO_Exceptions.Name_Error;
Use_Error : exception renames IO_Exceptions.Use_Error;
Device_Error : exception renames IO_Exceptions.Device_Error;
End_Error : exception renames IO_Exceptions.End_Error;
Data_Error : exception renames IO_Exceptions.Data_Error;
private
type File_Type is new System.Direct_IO.File_Type;
Bytes : constant Interfaces.C_Streams.size_t :=
Element_Type'Max_Size_In_Storage_Elements;
-- Size of an element in storage units
pragma Inline (Close);
pragma Inline (Create);
pragma Inline (Delete);
pragma Inline (End_Of_File);
pragma Inline (Form);
pragma Inline (Index);
pragma Inline (Is_Open);
pragma Inline (Mode);
pragma Inline (Name);
pragma Inline (Open);
pragma Inline (Read);
pragma Inline (Reset);
pragma Inline (Set_Index);
pragma Inline (Size);
pragma Inline (Write);
end Ada.Direct_IO;

154
gcc/ada/a-dynpri.adb Normal file
View File

@ -0,0 +1,154 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . D Y N A M I C _ P R I O R I T I E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.25 $
-- --
-- Copyright (C) 1991-2001 Florida State University --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Task_Identification;
-- used for Task_Id
-- Current_Task
-- Null_Task_Id
-- Is_Terminated
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
-- Set_Priority
-- Wakeup
-- Self
with System.Tasking;
-- used for Task_ID
with Ada.Exceptions;
-- used for Raise_Exception
with System.Tasking.Initialization;
-- used for Defer/Undefer_Abort
with Unchecked_Conversion;
package body Ada.Dynamic_Priorities is
use System.Tasking;
use Ada.Exceptions;
function Convert_Ids is new
Unchecked_Conversion
(Task_Identification.Task_Id, System.Tasking.Task_ID);
------------------
-- Get_Priority --
------------------
-- Inquire base priority of a task
function Get_Priority
(T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
return System.Any_Priority is
Target : constant Task_ID := Convert_Ids (T);
Error_Message : constant String := "Trying to get the priority of a ";
begin
if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then
Raise_Exception (Program_Error'Identity,
Error_Message & "null task");
end if;
if Task_Identification.Is_Terminated (T) then
Raise_Exception (Tasking_Error'Identity,
Error_Message & "null task");
end if;
return Target.Common.Base_Priority;
end Get_Priority;
------------------
-- Set_Priority --
------------------
-- Change base priority of a task dynamically
procedure Set_Priority
(Priority : System.Any_Priority;
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
is
Target : constant Task_ID := Convert_Ids (T);
Self_ID : constant Task_ID := System.Task_Primitives.Operations.Self;
Error_Message : constant String := "Trying to set the priority of a ";
begin
if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then
Raise_Exception (Program_Error'Identity,
Error_Message & "null task");
end if;
if Task_Identification.Is_Terminated (T) then
Raise_Exception (Tasking_Error'Identity,
Error_Message & "terminated task");
end if;
System.Tasking.Initialization.Defer_Abort (Self_ID);
System.Task_Primitives.Operations.Write_Lock (Target);
if Self_ID = Target then
Target.Common.Base_Priority := Priority;
System.Task_Primitives.Operations.Set_Priority (Target, Priority);
System.Task_Primitives.Operations.Unlock (Target);
System.Task_Primitives.Operations.Yield;
-- Yield is needed to enforce FIFO task dispatching.
-- LL Set_Priority is made while holding the RTS lock so that
-- it is inheriting high priority until it release all the RTS
-- locks.
-- If this is used in a system where Ceiling Locking is
-- not enforced we may end up getting two Yield effects.
else
Target.New_Base_Priority := Priority;
Target.Pending_Priority_Change := True;
Target.Pending_Action := True;
System.Task_Primitives.Operations.Wakeup
(Target, Target.Common.State);
-- If the task is suspended, wake it up to perform the change.
-- check for ceiling violations ???
System.Task_Primitives.Operations.Unlock (Target);
end if;
System.Tasking.Initialization.Undefer_Abort (Self_ID);
end Set_Priority;
end Ada.Dynamic_Priorities;

33
gcc/ada/a-dynpri.ads Normal file
View File

@ -0,0 +1,33 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . D Y N A M I C _ P R I O R I T I E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with System;
with Ada.Task_Identification;
package Ada.Dynamic_Priorities is
procedure Set_Priority
(Priority : System.Any_Priority;
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task);
function Get_Priority
(T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
return System.Any_Priority;
end Ada.Dynamic_Priorities;

54
gcc/ada/a-einuoc.adb Normal file
View File

@ -0,0 +1,54 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E --
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 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. --
-- --
-- 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 a GNAT-specific child function of Ada.Exceptions. It provides
-- clearly missing functionality for its parent package, and most reasonably
-- would simply be an added function to that package, but this change cannot
-- be made in a conforming manner.
function Ada.Exceptions.Is_Null_Occurrence
(X : Exception_Occurrence)
return Boolean
is
begin
-- The null exception is uniquely identified by the fact that the Id
-- value is null. No other exception occurrence can have a null Id.
if X.Id = Null_Id then
return True;
else
return False;
end if;
end Ada.Exceptions.Is_Null_Occurrence;

44
gcc/ada/a-einuoc.ads Normal file
View File

@ -0,0 +1,44 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 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. --
-- --
-- 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 a GNAT-specific child function of Ada.Exceptions. It provides
-- clearly missing functionality for its parent package, and most reasonably
-- would simply be an added function to that package, but this change cannot
-- be made in a conforming manner.
function Ada.Exceptions.Is_Null_Occurrence
(X : Exception_Occurrence)
return Boolean;
-- This function yields True if X is Null_Occurrence, and False otherwise

1980
gcc/ada/a-except.adb Normal file
View File

File diff suppressed because it is too large Load Diff

346
gcc/ada/a-except.ads Normal file
View File

@ -0,0 +1,346 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . E X C E P T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.50 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with ourself.
with System;
with System.Standard_Library;
package Ada.Exceptions is
type Exception_Id is private;
Null_Id : constant Exception_Id;
type Exception_Occurrence is limited private;
type Exception_Occurrence_Access is access all Exception_Occurrence;
Null_Occurrence : constant Exception_Occurrence;
function Exception_Name (X : Exception_Occurrence) return String;
-- Same as Exception_Name (Exception_Identity (X))
function Exception_Name (Id : Exception_Id) return String;
procedure Raise_Exception (E : Exception_Id; Message : String := "");
-- Note: it would be really nice to give a pragma No_Return for this
-- procedure, but it would be wrong, since Raise_Exception does return
-- if given the null exception. However we do special case the name in
-- the test in the compiler for issuing a warning for a missing return
-- after this call. Program_Error seems reasonable enough in such a case.
-- See also the routine Raise_Exception_Always in the private part.
function Exception_Message (X : Exception_Occurrence) return String;
procedure Reraise_Occurrence (X : Exception_Occurrence);
-- Note: it would be really nice to give a pragma No_Return for this
-- procedure, but it would be wrong, since Reraise_Occurrence does return
-- if the argument is the null exception occurrence. See also procedure
-- Reraise_Occurrence_Always in the private part of this package.
function Exception_Identity (X : Exception_Occurrence) return Exception_Id;
function Exception_Information (X : Exception_Occurrence) return String;
-- The format of the exception information is as follows:
--
-- exception name (as in Exception_Name)
-- message (or a null line if no message)
-- PID=nnnn
-- 0xyyyyyyyy 0xyyyyyyyy ...
--
-- The lines are separated by an ASCII.CR/ASCII.LF sequence.
-- The nnnn is the partition Id given as decimal digits.
-- The 0x... line represents traceback program counter locations,
-- in order with the first one being the exception location.
-- Note on ordering: the compiler uses the Save_Occurrence procedure, but
-- not the function from Rtsfind, so it is important that the procedure
-- come first, since Rtsfind finds the first matching entity.
procedure Save_Occurrence
(Target : out Exception_Occurrence;
Source : Exception_Occurrence);
function Save_Occurrence
(Source : Exception_Occurrence)
return Exception_Occurrence_Access;
private
package SSL renames System.Standard_Library;
subtype EOA is Exception_Occurrence_Access;
Exception_Msg_Max_Length : constant := 200;
------------------
-- Exception_Id --
------------------
subtype Code_Loc is System.Address;
-- Code location used in building exception tables and for call
-- addresses when propagating an exception (also traceback table)
-- Values of this type are created by using Label'Address or
-- extracted from machine states using Get_Code_Loc.
Null_Loc : constant Code_Loc := System.Null_Address;
-- Null code location, used to flag outer level frame
type Exception_Id is new SSL.Exception_Data_Ptr;
function EId_To_String (X : Exception_Id) return String;
function String_To_EId (S : String) return Exception_Id;
pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String);
-- Functions for implementing Exception_Id stream attributes
Null_Id : constant Exception_Id := null;
-------------------------
-- Private Subprograms --
-------------------------
function Current_Target_Exception return Exception_Occurrence;
pragma Export
(Ada, Current_Target_Exception,
"__gnat_current_target_exception");
-- This routine should return the current raised exception on targets
-- which have built-in exception handling such as the Java Virtual
-- Machine. For other targets this routine is simply ignored. Currently,
-- only JGNAT uses this. See 4jexcept.ads for details. The pragma Export
-- allows this routine to be accessed elsewhere in the run-time, even
-- though it is in the private part of this package (it is not allowed
-- to be in the visible part, since this is set by the reference manual).
function Exception_Name_Simple (X : Exception_Occurrence) return String;
-- Like Exception_Name, but returns the simple non-qualified name of
-- the exception. This is used to implement the Exception_Name function
-- in Current_Exceptions (the DEC compatible unit). It is called from
-- the compiler generated code (using Rtsfind, which does not respect
-- the private barrier, so we can place this function in the private
-- part where the compiler can find it, but the spec is unchanged.)
procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
pragma No_Return (Raise_Exception_Always);
pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception");
-- This differs from Raise_Exception only in that the caller has determined
-- that for sure the parameter E is not null, and that therefore the call
-- to this procedure cannot return. The expander converts Raise_Exception
-- calls to Raise_Exception_Always if it can determine this is the case.
-- The Export allows this routine to be accessed from Pure units.
procedure Raise_No_Msg (E : Exception_Id);
pragma No_Return (Raise_No_Msg);
-- Raises an exception with no message with given exception id value.
-- Abort is deferred before the raise call.
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : SSL.Big_String_Ptr);
pragma Export
(Ada, Raise_From_Signal_Handler,
"ada__exceptions__raise_from_signal_handler");
pragma No_Return (Raise_From_Signal_Handler);
-- This routine is used to raise an exception from a signal handler.
-- The signal handler has already stored the machine state (i.e. the
-- state that corresponds to the location at which the signal was
-- raised). E is the Exception_Id specifying what exception is being
-- raised, and M is a pointer to a null-terminated string which is the
-- message to be raised. Note that this routine never returns, so it is
-- permissible to simply jump to this routine, rather than call it. This
-- may be appropriate for systems where the right way to get out of a
-- signal handler is to alter the PC value in the machine state or in
-- some other way ask the operating system to return here rather than
-- to the original location.
procedure Raise_With_C_Msg
(E : Exception_Id;
M : SSL.Big_String_Ptr);
pragma Export (Ada, Raise_With_C_Msg, "ada__exceptions__raise_with_c_msg");
pragma No_Return (Raise_With_C_Msg);
-- Raises an exception with with given exception id value and message.
-- M is a null terminated string with the message to be raised. Abort
-- is deferred before the raise call.
procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_Always);
-- This differs from Raise_Occurrence only in that the caller guarantees
-- that for sure the parameter X is not the null occurrence, and that
-- therefore this procedure cannot return. The expander uses this routine
-- in the translation of a raise statement with no parameter (reraise).
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_No_Defer);
-- Exactly like Reraise_Occurrence, except that abort is not deferred
-- before the call and the parameter X is known not to be the null
-- occurrence. This is used in generated code when it is known
-- that abort is already deferred.
procedure SDP_Table_Build
(SDP_Addresses : System.Address;
SDP_Count : Natural;
Elab_Addresses : System.Address;
Elab_Addr_Count : Natural);
pragma Export (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
-- This is the routine that is called to build and sort the list of
-- subprogram descriptor pointers. In the normal case it is called
-- once at the start of execution, but it can also be called as part
-- of the explicit initialization routine (adainit) when there is no
-- Ada main program. In particular, in the case where multiple Ada
-- libraries are present, this routine can be called more than once
-- for each library, in which case it augments the previously set
-- table with the new entries specified by the parameters.
--
-- SDP_Addresses Address of the start of the list of addresses of
-- __gnat_unit_name__SDP values constructed for each
-- unit, (see System.Exceptions).
--
-- SDP_Count Number of entries in SDP_Addresses
--
-- Elab_Addresses Address of the start of a list of addresses of
-- generated Ada elaboration routines, as well as
-- one extra entry for the generated main program.
-- These are used to generate the dummy SDP's that
-- mark the outer scope.
--
-- Elab_Addr_Count Number of entries in Elab_Addresses
procedure Break_Start;
pragma Export (C, Break_Start, "__gnat_break_start");
-- This is a dummy procedure that is called at the start of execution.
-- Its sole purpose is to provide a well defined point for the placement
-- of a main program breakpoint. We put the routine in Ada.Exceptions so
-- that the standard mechanism of always stepping up from breakpoints
-- within Ada.Exceptions leaves us sitting in the main program.
-----------------------
-- Polling Interface --
-----------------------
-- The GNAT compiler has an option to generate polling calls to the Poll
-- routine in this package. Specifying the -gnatP option for a compilation
-- causes a call to Ada.Exceptions.Poll to be generated on every subprogram
-- entry and on every iteration of a loop, thus avoiding the possibility of
-- a case of unbounded time between calls.
-- This polling interface may be used for instrumentation or debugging
-- purposes (e.g. implementing watchpoints in software or in the debugger).
-- In the GNAT technology itself, this interface is used to implement
-- immediate aynschronous transfer of control and immediate abort on
-- targets which do not provide for one thread interrupting another.
-- Note: this used to be in a separate unit called System.Poll, but that
-- caused horrible circular elaboration problems between System.Poll and
-- Ada.Exceptions. One way of solving such circularities is unification!
procedure Poll;
-- Check for asynchronous abort. Note that we do not inline the body.
-- This makes the interface more useful for debugging purposes.
--------------------------
-- Exception_Occurrence --
--------------------------
Max_Tracebacks : constant := 50;
-- Maximum number of trace backs stored in exception occurrence
type Tracebacks_Array is array (1 .. Max_Tracebacks) of Code_Loc;
-- Traceback array stored in exception occurrence
type Exception_Occurrence is record
Id : Exception_Id;
-- Exception_Identity for this exception occurrence
-- WARNING System.System.Finalization_Implementation.Finalize_List
-- relies on the fact that this field is always first in the exception
-- occurrence
Msg_Length : Natural := 0;
-- Length of message (zero = no message)
Msg : String (1 .. Exception_Msg_Max_Length);
-- Characters of message
Cleanup_Flag : Boolean;
-- The cleanup flag is normally False, it is set True for an exception
-- occurrence passed to a cleanup routine, and will still be set True
-- when the cleanup routine does a Reraise_Occurrence call using this
-- exception occurrence. This is used to avoid recording a bogus trace
-- back entry from this reraise call.
Exception_Raised : Boolean := False;
-- Set to true to indicate that this exception occurrence has actually
-- been raised. When an exception occurrence is first created, this is
-- set to False, then when it is processed by Raise_Current_Exception,
-- it is set to True. If Raise_Current_Exception is used to raise an
-- exception for which this flag is already True, then it knows that
-- it is dealing with the reraise case (which is useful to distinguish
-- for exception tracing purposes).
Pid : Natural;
-- Partition_Id for partition raising exception
Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0;
-- Number of traceback entries stored
Tracebacks : Tracebacks_Array;
-- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks))
end record;
function "=" (Left, Right : Exception_Occurrence) return Boolean
is abstract;
-- Don't allow comparison on exception occurrences, we should not need
-- this, and it would not work right, because of the Msg and Tracebacks
-- fields which have unused entries not copied by Save_Occurrence.
function EO_To_String (X : Exception_Occurrence) return String;
function String_To_EO (S : String) return Exception_Occurrence;
pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String);
-- Functions for implementing Exception_Occurrence stream attributes
Null_Occurrence : constant Exception_Occurrence := (
Id => Null_Id,
Msg_Length => 0,
Msg => (others => ' '),
Cleanup_Flag => False,
Exception_Raised => False,
Pid => 0,
Num_Tracebacks => 0,
Tracebacks => (others => Null_Loc));
end Ada.Exceptions;

47
gcc/ada/a-excpol.adb Normal file
View File

@ -0,0 +1,47 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . E X C E P T I O N S . P O L L --
-- --
-- B o d y --
-- (dummy version where polling is not used) --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
separate (Ada.Exceptions)
----------
-- Poll --
----------
procedure Poll is
begin
null;
end Poll;

51
gcc/ada/a-exctra.adb Normal file
View File

@ -0,0 +1,51 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . E X C E P T I O N S . T R A C E B A C K --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 1999-2001 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package body Ada.Exceptions.Traceback is
function Tracebacks
(E : Exception_Occurrence)
return GNAT.Traceback.Tracebacks_Array
is
begin
return
GNAT.Traceback.Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks));
end Tracebacks;
end Ada.Exceptions.Traceback;

56
gcc/ada/a-exctra.ads Normal file
View File

@ -0,0 +1,56 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . E X C E P T I O N S . T R A C E B A C K --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 1999-2001 Free Software Foundation, 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 is part of the support for tracebacks on exceptions. It is
-- used ONLY from GNAT.Traceback.Symbolic and is provided to get access to
-- the tracebacks in an exception occurrence. It may not be used directly
-- from the Ada hierarchy (since it references GNAT.Traceback).
with GNAT.Traceback;
package Ada.Exceptions.Traceback is
function Tracebacks
(E : Exception_Occurrence)
return GNAT.Traceback.Tracebacks_Array;
-- This function extracts the traceback information from an exception
-- occurrence, and returns it formatted in the manner required for
-- processing in GNAT.Traceback. See g-traceb.ads for details.
end Ada.Exceptions.Traceback;

73
gcc/ada/a-filico.adb Normal file
View File

@ -0,0 +1,73 @@
-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . L I S T _ F I N A L I Z A T I O N --
-- --
-- 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. --
-- --
-- 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.Finalization_Implementation;
package body Ada.Finalization.List_Controller is
package SFI renames System.Finalization_Implementation;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out List_Controller) is
use type SFR.Finalizable_Ptr;
Last_Ptr : constant SFR.Finalizable_Ptr := Object.Last'Unchecked_Access;
begin
while Object.First.Next /= Last_Ptr loop
SFI.Finalize_One (Object.First.Next.all);
end loop;
end Finalize;
procedure Finalize (Object : in out Simple_List_Controller) is
begin
SFI.Finalize_List (Object.F);
Object.F := null;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Object : in out List_Controller) is
begin
Object.F := Object.First'Unchecked_Access;
Object.First.Next := Object.Last 'Unchecked_Access;
Object.Last.Prev := Object.First'Unchecked_Access;
end Initialize;
end Ada.Finalization.List_Controller;

105
gcc/ada/a-filico.ads Normal file
View File

@ -0,0 +1,105 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E R --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992-1997 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.Finalization_Root;
package Ada.Finalization.List_Controller is
pragma Elaborate_Body (List_Controller);
package SFR renames System.Finalization_Root;
----------------------------
-- Simple_List_Controller --
----------------------------
type Simple_List_Controller is new Ada.Finalization.Limited_Controlled
with record
F : SFR.Finalizable_Ptr;
end record;
-- Used by the compiler to carry a list of temporary objects that
-- needs to be finalized after having being used. This list is
-- embedded in a controlled type so that if an exception is raised
-- while those temporaries are still in use, they will be reclaimed
-- by the normal finalization mechanism.
procedure Finalize (Object : in out Simple_List_Controller);
---------------------
-- List_Controller --
---------------------
-- Management of a bidirectional linked heterogenous list of
-- dynamically Allocated objects. To simplify the management of the
-- linked list, the First and Last elements are statically part of the
-- original List controller:
--
-- +------------+
-- | --|-->--
-- +------------+
-- |--<-- | record with ctrl components
-- |------------| +----------+
-- +--|-- L | | |
-- | |------------| | |
-- | |+--------+ | +--------+ |+--------+|
-- +->|| prev | F|---<---|-- |----<---||-- ||--<--+
-- ||--------| i| |--------| ||--------|| |
-- || next | r|--->---| --|---->---|| --||--------+
-- |+--------+ s| |--------| ||--------|| | |
-- | t| | ctrl | || || | |
-- | | : : |+--------+| | |
-- | | : object : |rec | | |
-- | | : : |controller| | |
-- | | | | | | | v
-- |+--------+ | +--------+ +----------+ | |
-- || prev -|-L|--------------------->--------------------+ |
-- ||--------| a| |
-- || next | s|-------------------<-------------------------+
-- |+--------+ t|
-- | |
-- +------------+
type List_Controller is new Ada.Finalization.Limited_Controlled
with record
F : SFR.Finalizable_Ptr;
First,
Last : aliased SFR.Root_Controlled;
end record;
-- Controls the chains of dynamically allocated controlled
-- objects makes sure that they get finalized upon exit from
-- the access type that defined them
procedure Initialize (Object : in out List_Controller);
procedure Finalize (Object : in out List_Controller);
end Ada.Finalization.List_Controller;

86
gcc/ada/a-finali.adb Normal file
View File

@ -0,0 +1,86 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . F I N A L I Z A T I O N --
-- --
-- B o d y --
-- --
-- $Revision: 1.10 $
-- --
-- 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.Finalization_Root; use System.Finalization_Root;
package body Ada.Finalization is
---------
-- "=" --
---------
function "=" (A, B : Controlled) return Boolean is
begin
return Empty_Root_Controlled (A) = Empty_Root_Controlled (B);
end "=";
------------
-- Adjust --
------------
procedure Adjust (Object : in out Controlled) is
begin
null;
end Adjust;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Controlled) is
begin
null;
end Finalize;
procedure Finalize (Object : in out Limited_Controlled) is
begin
null;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Object : in out Controlled) is
begin
null;
end Initialize;
procedure Initialize (Object : in out Limited_Controlled) is
begin
null;
end Initialize;
end Ada.Finalization;

68
gcc/ada/a-finali.ads Normal file
View File

@ -0,0 +1,68 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . F I N A L I Z A T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.17 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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 System.Finalization_Root;
package Ada.Finalization is
pragma Preelaborate (Finalization);
type Controlled is abstract tagged private;
procedure Initialize (Object : in out Controlled);
procedure Adjust (Object : in out Controlled);
procedure Finalize (Object : in out Controlled);
type Limited_Controlled is abstract tagged limited private;
procedure Initialize (Object : in out Limited_Controlled);
procedure Finalize (Object : in out Limited_Controlled);
private
package SFR renames System.Finalization_Root;
type Controlled is abstract new SFR.Root_Controlled with null record;
function "=" (A, B : Controlled) return Boolean;
-- Need to be defined explictly because we don't want to compare the
-- hidden pointers
type Limited_Controlled is
abstract new SFR.Root_Controlled with null record;
end Ada.Finalization;

23
gcc/ada/a-flteio.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . F L O A T _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
pragma Elaborate_All (Ada.Text_IO);
package Ada.Float_Text_IO is
new Ada.Text_IO.Float_IO (Float);

21
gcc/ada/a-fwteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . F L O A T _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Float_Wide_Text_IO is
new Ada.Wide_Text_IO.Float_IO (Float);

21
gcc/ada/a-inteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . I N T E G E R _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Integer_Text_IO is
new Ada.Text_IO.Integer_IO (Integer);

139
gcc/ada/a-interr.adb Normal file
View File

@ -0,0 +1,139 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . I N T E R R U P T S --
-- --
-- B o d y --
-- --
-- $Revision: 1.12 $ --
-- --
-- Copyright (C) 1991-2001 Florida State University --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Interrupts;
-- used for Interrupt_ID
-- Parameterless_Handler
-- Is_Reserved
-- Is_Handler_Attached
-- Current_Handler
-- Attach_Handler
-- Exchange_Handler
-- Detach_Handler
-- Reference
with Unchecked_Conversion;
package body Ada.Interrupts is
package SI renames System.Interrupts;
function To_System is new Unchecked_Conversion
(Parameterless_Handler, SI.Parameterless_Handler);
function To_Ada is new Unchecked_Conversion
(SI.Parameterless_Handler, Parameterless_Handler);
--------------------
-- Attach_Handler --
--------------------
procedure Attach_Handler
(New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID)
is
begin
SI.Attach_Handler
(To_System (New_Handler), SI.Interrupt_ID (Interrupt), False);
end Attach_Handler;
---------------------
-- Current_Handler --
---------------------
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler
is
begin
return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt)));
end Current_Handler;
--------------------
-- Detach_Handler --
--------------------
procedure Detach_Handler (Interrupt : in Interrupt_ID) is
begin
SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False);
end Detach_Handler;
----------------------
-- Exchange_Handler --
----------------------
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID)
is
H : SI.Parameterless_Handler;
begin
SI.Exchange_Handler
(H, To_System (New_Handler),
SI.Interrupt_ID (Interrupt), False);
Old_Handler := To_Ada (H);
end Exchange_Handler;
-----------------
-- Is_Attached --
-----------------
function Is_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
return SI.Is_Handler_Attached (SI.Interrupt_ID (Interrupt));
end Is_Attached;
-----------------
-- Is_Reserved --
-----------------
function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
begin
return SI.Is_Reserved (SI.Interrupt_ID (Interrupt));
end Is_Reserved;
---------------
-- Reference --
---------------
function Reference (Interrupt : Interrupt_ID) return System.Address is
begin
return SI.Reference (SI.Interrupt_ID (Interrupt));
end Reference;
end Ada.Interrupts;

77
gcc/ada/a-interr.ads Normal file
View File

@ -0,0 +1,77 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . I N T E R R U P T S --
-- --
-- S p e c --
-- --
-- $Revision: 1.16 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, 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 System.Interrupts;
-- used for Ada_Interrupt_ID.
package Ada.Interrupts is
type Interrupt_ID is new System.Interrupts.Ada_Interrupt_ID;
type Parameterless_Handler is access protected procedure;
function Is_Reserved (Interrupt : Interrupt_ID) return Boolean;
function Is_Attached (Interrupt : Interrupt_ID) return Boolean;
function Current_Handler
(Interrupt : Interrupt_ID)
return Parameterless_Handler;
procedure Attach_Handler
(New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID);
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID);
procedure Detach_Handler (Interrupt : Interrupt_ID);
function Reference (Interrupt : Interrupt_ID) return System.Address;
private
pragma Inline (Is_Reserved);
pragma Inline (Is_Attached);
pragma Inline (Current_Handler);
pragma Inline (Attach_Handler);
pragma Inline (Detach_Handler);
pragma Inline (Exchange_Handler);
end Ada.Interrupts;

31
gcc/ada/a-intnam.ads Normal file
View File

@ -0,0 +1,31 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . I N T E R R U P T S . N A M E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- The standard implementation of this spec contains only dummy interrupt
-- names. These dummy entries permit checking out code for correctness of
-- semantics, even if interrupts are not supported.
-- For specific implementations that fully support interrupts, this package
-- spec is replaced by an implementation dependent version that defines the
-- interrupts available on the system.
package Ada.Interrupts.Names is
DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
end Ada.Interrupts.Names;

49
gcc/ada/a-intsig.adb Normal file
View File

@ -0,0 +1,49 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . I N T E R R U P T S . S I G N A L --
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (C) 2000 Free Software Foundation, Inc. --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
--
with System.Interrupt_Management.Operations;
package body Ada.Interrupts.Signal is
-------------------------
-- Generate_Interrupt --
-------------------------
procedure Generate_Interrupt (Interrupt : Interrupt_ID) is
begin
System.Interrupt_Management.Operations.Interrupt_Self_Process
(System.Interrupt_Management.Interrupt_ID (Interrupt));
end Generate_Interrupt;
end Ada.Interrupts.Signal;

47
gcc/ada/a-intsig.ads Normal file
View File

@ -0,0 +1,47 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . I N T E R R U P T S . S I G N A L --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (C) 2000 Free Software Foundation, Inc. --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
--
-- This package encapsulates the procedures for generating interrupts
-- by user programs and avoids importing low level children of System
-- (e.g. System.Interrupt_Management.Operations), or defining an interface
-- to complex system calls.
--
package Ada.Interrupts.Signal is
procedure Generate_Interrupt (Interrupt : Interrupt_ID);
-- Generate Interrupt at the process level
end Ada.Interrupts.Signal;

30
gcc/ada/a-ioexce.ads Normal file
View File

@ -0,0 +1,30 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . I O _ E X C E P T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.IO_Exceptions is
pragma Pure (IO_Exceptions);
Status_Error : exception;
Mode_Error : exception;
Name_Error : exception;
Use_Error : exception;
Device_Error : exception;
End_Error : exception;
Data_Error : exception;
Layout_Error : exception;
end Ada.IO_Exceptions;

21
gcc/ada/a-iwteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . I N T E G E R _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Integer_Wide_Text_IO is
new Ada.Wide_Text_IO.Integer_IO (Integer);

21
gcc/ada/a-lfteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ F L O A T _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Long_Float_Text_IO is
new Ada.Text_IO.Float_IO (Long_Float);

21
gcc/ada/a-lfwtio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ F L O A T _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Long_Float_Wide_Text_IO is
new Ada.Wide_Text_IO.Float_IO (Long_Float);

21
gcc/ada/a-liteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ I N T E G E R _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Long_Integer_Text_IO is
new Ada.Text_IO.Integer_IO (Long_Integer);

21
gcc/ada/a-liwtio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ I N T E G E R _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Long_Integer_Wide_Text_IO is
new Ada.Wide_Text_IO.Integer_IO (Long_Integer);

21
gcc/ada/a-llftio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ L O N G _ F L O A T _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Long_Long_Float_Text_IO is
new Ada.Text_IO.Float_IO (Long_Long_Float);

21
gcc/ada/a-llfwti.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ L O N G _ F L O A T _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Long_Long_Float_Wide_Text_IO is
new Ada.Wide_Text_IO.Float_IO (Long_Long_Float);

21
gcc/ada/a-llitio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ L O N G _ I N T E G E R _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Long_Long_Integer_Text_IO is
new Ada.Text_IO.Integer_IO (Long_Long_Integer);

21
gcc/ada/a-lliwti.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Long_Long_Integer_Wide_Text_IO is
new Ada.Wide_Text_IO.Integer_IO (Long_Long_Integer);

23
gcc/ada/a-ncelfu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.GENERIC_COMPLEX.ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
package Ada.Numerics.Complex_Elementary_Functions is
new Ada.Numerics.Generic_Complex_Elementary_Functions
(Ada.Numerics.Complex_Types);

709
gcc/ada/a-ngcefu.adb Normal file
View File

@ -0,0 +1,709 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS --
-- --
-- B o d y --
-- --
-- $Revision: 1.13 $
-- --
-- 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 Ada.Numerics.Generic_Elementary_Functions;
package body Ada.Numerics.Generic_Complex_Elementary_Functions is
package Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Real'Base);
use Elementary_Functions;
PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971;
PI_2 : constant := PI / 2.0;
Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
subtype T is Real'Base;
Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa);
Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa);
Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1);
Root_Root_Epsilon : constant T := Sqrt_Two **
((1 - T'Model_Mantissa) / 2);
Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0;
Complex_Zero : constant Complex := (0.0, 0.0);
Complex_One : constant Complex := (1.0, 0.0);
Complex_I : constant Complex := (0.0, 1.0);
Half_Pi : constant Complex := (PI_2, 0.0);
--------
-- ** --
--------
function "**" (Left : Complex; Right : Complex) return Complex is
begin
if Re (Right) = 0.0
and then Im (Right) = 0.0
and then Re (Left) = 0.0
and then Im (Left) = 0.0
then
raise Argument_Error;
elsif Re (Left) = 0.0
and then Im (Left) = 0.0
and then Re (Right) < 0.0
then
raise Constraint_Error;
elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
return Left;
elsif Right = (0.0, 0.0) then
return Complex_One;
elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
return 1.0 + Right;
elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then
return Left;
else
return Exp (Right * Log (Left));
end if;
end "**";
function "**" (Left : Real'Base; Right : Complex) return Complex is
begin
if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then
raise Argument_Error;
elsif Left = 0.0 and then Re (Right) < 0.0 then
raise Constraint_Error;
elsif Left = 0.0 then
return Compose_From_Cartesian (Left, 0.0);
elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
return Complex_One;
elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then
return Compose_From_Cartesian (Left, 0.0);
else
return Exp (Log (Left) * Right);
end if;
end "**";
function "**" (Left : Complex; Right : Real'Base) return Complex is
begin
if Right = 0.0
and then Re (Left) = 0.0
and then Im (Left) = 0.0
then
raise Argument_Error;
elsif Re (Left) = 0.0
and then Im (Left) = 0.0
and then Right < 0.0
then
raise Constraint_Error;
elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
return Left;
elsif Right = 0.0 then
return Complex_One;
elsif Right = 1.0 then
return Left;
else
return Exp (Right * Log (Left));
end if;
end "**";
------------
-- Arccos --
------------
function Arccos (X : Complex) return Complex is
Result : Complex;
begin
if X = Complex_One then
return Complex_Zero;
elsif abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return Half_Pi - X;
elsif abs Re (X) > Inv_Square_Root_Epsilon or else
abs Im (X) > Inv_Square_Root_Epsilon
then
return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) +
Complex_I * Sqrt ((1.0 - X) / 2.0));
end if;
Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X));
if Im (X) = 0.0
and then abs Re (X) <= 1.00
then
Set_Im (Result, Im (X));
end if;
return Result;
end Arccos;
-------------
-- Arccosh --
-------------
function Arccosh (X : Complex) return Complex is
Result : Complex;
begin
if X = Complex_One then
return Complex_Zero;
elsif abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X));
elsif abs Re (X) > Inv_Square_Root_Epsilon or else
abs Im (X) > Inv_Square_Root_Epsilon
then
Result := Log_Two + Log (X);
else
Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) +
Sqrt ((X - 1.0) / 2.0));
end if;
if Re (Result) <= 0.0 then
Result := -Result;
end if;
return Result;
end Arccosh;
------------
-- Arccot --
------------
function Arccot (X : Complex) return Complex is
Xt : Complex;
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return Half_Pi - X;
elsif abs Re (X) > 1.0 / Epsilon or else
abs Im (X) > 1.0 / Epsilon
then
Xt := Complex_One / X;
if Re (X) < 0.0 then
Set_Re (Xt, PI - Re (Xt));
return Xt;
else
return Xt;
end if;
end if;
Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0;
if Re (Xt) < 0.0 then
Xt := PI + Xt;
end if;
return Xt;
end Arccot;
--------------
-- Arctcoth --
--------------
function Arccoth (X : Complex) return Complex is
R : Complex;
begin
if X = (0.0, 0.0) then
return Compose_From_Cartesian (0.0, PI_2);
elsif abs Re (X) < Square_Root_Epsilon
and then abs Im (X) < Square_Root_Epsilon
then
return PI_2 * Complex_I + X;
elsif abs Re (X) > 1.0 / Epsilon or else
abs Im (X) > 1.0 / Epsilon
then
if Im (X) > 0.0 then
return (0.0, 0.0);
else
return PI * Complex_I;
end if;
elsif Im (X) = 0.0 and then Re (X) = 1.0 then
raise Constraint_Error;
elsif Im (X) = 0.0 and then Re (X) = -1.0 then
raise Constraint_Error;
end if;
begin
R := Log ((1.0 + X) / (X - 1.0)) / 2.0;
exception
when Constraint_Error =>
R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0;
end;
if Im (R) < 0.0 then
Set_Im (R, PI + Im (R));
end if;
if Re (X) = 0.0 then
Set_Re (R, Re (X));
end if;
return R;
end Arccoth;
------------
-- Arcsin --
------------
function Arcsin (X : Complex) return Complex is
Result : Complex;
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
elsif abs Re (X) > Inv_Square_Root_Epsilon or else
abs Im (X) > Inv_Square_Root_Epsilon
then
Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I));
if Im (Result) > PI_2 then
Set_Im (Result, PI - Im (X));
elsif Im (Result) < -PI_2 then
Set_Im (Result, -(PI + Im (X)));
end if;
end if;
Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X));
if Re (X) = 0.0 then
Set_Re (Result, Re (X));
elsif Im (X) = 0.0
and then abs Re (X) <= 1.00
then
Set_Im (Result, Im (X));
end if;
return Result;
end Arcsin;
-------------
-- Arcsinh --
-------------
function Arcsinh (X : Complex) return Complex is
Result : Complex;
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
elsif abs Re (X) > Inv_Square_Root_Epsilon or else
abs Im (X) > Inv_Square_Root_Epsilon
then
Result := Log_Two + Log (X); -- may have wrong sign
if (Re (X) < 0.0 and Re (Result) > 0.0)
or else (Re (X) > 0.0 and Re (Result) < 0.0)
then
Set_Re (Result, -Re (Result));
end if;
return Result;
end if;
Result := Log (X + Sqrt (1.0 + X * X));
if Re (X) = 0.0 then
Set_Re (Result, Re (X));
elsif Im (X) = 0.0 then
Set_Im (Result, Im (X));
end if;
return Result;
end Arcsinh;
------------
-- Arctan --
------------
function Arctan (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
else
return -Complex_I * (Log (1.0 + Complex_I * X)
- Log (1.0 - Complex_I * X)) / 2.0;
end if;
end Arctan;
-------------
-- Arctanh --
-------------
function Arctanh (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
else
return (Log (1.0 + X) - Log (1.0 - X)) / 2.0;
end if;
end Arctanh;
---------
-- Cos --
---------
function Cos (X : Complex) return Complex is
begin
return
Compose_From_Cartesian
(Cos (Re (X)) * Cosh (Im (X)),
-Sin (Re (X)) * Sinh (Im (X)));
end Cos;
----------
-- Cosh --
----------
function Cosh (X : Complex) return Complex is
begin
return
Compose_From_Cartesian
(Cosh (Re (X)) * Cos (Im (X)),
Sinh (Re (X)) * Sin (Im (X)));
end Cosh;
---------
-- Cot --
---------
function Cot (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return Complex_One / X;
elsif Im (X) > Log_Inverse_Epsilon_2 then
return -Complex_I;
elsif Im (X) < -Log_Inverse_Epsilon_2 then
return Complex_I;
end if;
return Cos (X) / Sin (X);
end Cot;
----------
-- Coth --
----------
function Coth (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return Complex_One / X;
elsif Re (X) > Log_Inverse_Epsilon_2 then
return Complex_One;
elsif Re (X) < -Log_Inverse_Epsilon_2 then
return -Complex_One;
else
return Cosh (X) / Sinh (X);
end if;
end Coth;
---------
-- Exp --
---------
function Exp (X : Complex) return Complex is
EXP_RE_X : Real'Base := Exp (Re (X));
begin
return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)),
EXP_RE_X * Sin (Im (X)));
end Exp;
function Exp (X : Imaginary) return Complex is
ImX : Real'Base := Im (X);
begin
return Compose_From_Cartesian (Cos (ImX), Sin (ImX));
end Exp;
---------
-- Log --
---------
function Log (X : Complex) return Complex is
ReX : Real'Base;
ImX : Real'Base;
Z : Complex;
begin
if Re (X) = 0.0 and then Im (X) = 0.0 then
raise Constraint_Error;
elsif abs (1.0 - Re (X)) < Root_Root_Epsilon
and then abs Im (X) < Root_Root_Epsilon
then
Z := X;
Set_Re (Z, Re (Z) - 1.0);
return (1.0 - (1.0 / 2.0 -
(1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z;
end if;
begin
ReX := Log (Modulus (X));
exception
when Constraint_Error =>
ReX := Log (Modulus (X / 2.0)) - Log_Two;
end;
ImX := Arctan (Im (X), Re (X));
if ImX > PI then
ImX := ImX - 2.0 * PI;
end if;
return Compose_From_Cartesian (ReX, ImX);
end Log;
---------
-- Sin --
---------
function Sin (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon then
return X;
end if;
return
Compose_From_Cartesian
(Sin (Re (X)) * Cosh (Im (X)),
Cos (Re (X)) * Sinh (Im (X)));
end Sin;
----------
-- Sinh --
----------
function Sinh (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
else
return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)),
Cosh (Re (X)) * Sin (Im (X)));
end if;
end Sinh;
----------
-- Sqrt --
----------
function Sqrt (X : Complex) return Complex is
ReX : constant Real'Base := Re (X);
ImX : constant Real'Base := Im (X);
XR : constant Real'Base := abs Re (X);
YR : constant Real'Base := abs Im (X);
R : Real'Base;
R_X : Real'Base;
R_Y : Real'Base;
begin
-- Deal with pure real case, see (RM G.1.2(39))
if ImX = 0.0 then
if ReX > 0.0 then
return
Compose_From_Cartesian
(Sqrt (ReX), 0.0);
elsif ReX = 0.0 then
return X;
else
return
Compose_From_Cartesian
(0.0, Real'Copy_Sign (Sqrt (-ReX), ImX));
end if;
elsif ReX = 0.0 then
R_X := Sqrt (YR / 2.0);
if ImX > 0.0 then
return Compose_From_Cartesian (R_X, R_X);
else
return Compose_From_Cartesian (R_X, -R_X);
end if;
else
R := Sqrt (XR ** 2 + YR ** 2);
-- If the square of the modulus overflows, try rescaling the
-- real and imaginary parts. We cannot depend on an exception
-- being raised on all targets.
if R > Real'Base'Last then
raise Constraint_Error;
end if;
-- We are solving the system
-- XR = R_X ** 2 - Y_R ** 2 (1)
-- YR = 2.0 * R_X * R_Y (2)
--
-- The symmetric solution involves square roots for both R_X and
-- R_Y, but it is more accurate to use the square root with the
-- larger argument for either R_X or R_Y, and equation (2) for the
-- other.
if ReX < 0.0 then
R_Y := Sqrt (0.5 * (R - ReX));
R_X := YR / (2.0 * R_Y);
else
R_X := Sqrt (0.5 * (R + ReX));
R_Y := YR / (2.0 * R_X);
end if;
end if;
if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
R_Y := -R_Y;
end if;
return Compose_From_Cartesian (R_X, R_Y);
exception
when Constraint_Error =>
-- Rescale and try again.
R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0)));
R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0));
R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0));
if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
R_Y := -R_Y;
end if;
return Compose_From_Cartesian (R_X, R_Y);
end Sqrt;
---------
-- Tan --
---------
function Tan (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
elsif Im (X) > Log_Inverse_Epsilon_2 then
return Complex_I;
elsif Im (X) < -Log_Inverse_Epsilon_2 then
return -Complex_I;
else
return Sin (X) / Cos (X);
end if;
end Tan;
----------
-- Tanh --
----------
function Tanh (X : Complex) return Complex is
begin
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
return X;
elsif Re (X) > Log_Inverse_Epsilon_2 then
return Complex_One;
elsif Re (X) < -Log_Inverse_Epsilon_2 then
return -Complex_One;
else
return Sinh (X) / Cosh (X);
end if;
end Tanh;
end Ada.Numerics.Generic_Complex_Elementary_Functions;

57
gcc/ada/a-ngcefu.ads Normal file
View File

@ -0,0 +1,57 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Complex_Types;
generic
with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>);
use Complex_Types;
package Ada.Numerics.Generic_Complex_Elementary_Functions is
pragma Pure (Ada.Numerics.Generic_Complex_Elementary_Functions);
function Sqrt (X : Complex) return Complex;
function Log (X : Complex) return Complex;
function Exp (X : Complex) return Complex;
function Exp (X : Imaginary) return Complex;
function "**" (Left : Complex; Right : Complex) return Complex;
function "**" (Left : Complex; Right : Real'Base) return Complex;
function "**" (Left : Real'Base; Right : Complex) return Complex;
function Sin (X : Complex) return Complex;
function Cos (X : Complex) return Complex;
function Tan (X : Complex) return Complex;
function Cot (X : Complex) return Complex;
function Arcsin (X : Complex) return Complex;
function Arccos (X : Complex) return Complex;
function Arctan (X : Complex) return Complex;
function Arccot (X : Complex) return Complex;
function Sinh (X : Complex) return Complex;
function Cosh (X : Complex) return Complex;
function Tanh (X : Complex) return Complex;
function Coth (X : Complex) return Complex;
function Arcsinh (X : Complex) return Complex;
function Arccosh (X : Complex) return Complex;
function Arctanh (X : Complex) return Complex;
function Arccoth (X : Complex) return Complex;
end Ada.Numerics.Generic_Complex_Elementary_Functions;

667
gcc/ada/a-ngcoty.adb Normal file
View File

@ -0,0 +1,667 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.16 $
-- --
-- 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 Ada.Numerics.Aux; use Ada.Numerics.Aux;
package body Ada.Numerics.Generic_Complex_Types is
subtype R is Real'Base;
Two_Pi : constant R := R (2.0) * Pi;
Half_Pi : constant R := Pi / R (2.0);
---------
-- "*" --
---------
function "*" (Left, Right : Complex) return Complex is
X : R;
Y : R;
begin
X := Left.Re * Right.Re - Left.Im * Right.Im;
Y := Left.Re * Right.Im + Left.Im * Right.Re;
-- If either component overflows, try to scale.
if abs (X) > R'Last then
X := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Im / 2.0));
end if;
if abs (Y) > R'Last then
Y := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Re / 2.0));
end if;
return (X, Y);
end "*";
function "*" (Left, Right : Imaginary) return Real'Base is
begin
return -R (Left) * R (Right);
end "*";
function "*" (Left : Complex; Right : Real'Base) return Complex is
begin
return Complex'(Left.Re * Right, Left.Im * Right);
end "*";
function "*" (Left : Real'Base; Right : Complex) return Complex is
begin
return (Left * Right.Re, Left * Right.Im);
end "*";
function "*" (Left : Complex; Right : Imaginary) return Complex is
begin
return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right));
end "*";
function "*" (Left : Imaginary; Right : Complex) return Complex is
begin
return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re);
end "*";
function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is
begin
return Left * Imaginary (Right);
end "*";
function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is
begin
return Imaginary (Left * R (Right));
end "*";
----------
-- "**" --
----------
function "**" (Left : Complex; Right : Integer) return Complex is
Result : Complex := (1.0, 0.0);
Factor : Complex := Left;
Exp : Integer := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2. For positive exponents we
-- multiply the result by this factor, for negative exponents, we
-- divide by this factor.
if Exp >= 0 then
-- For a positive exponent, if we get a constraint error during
-- this loop, it is an overflow, and the constraint error will
-- simply be passed on to the caller.
while Exp /= 0 loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Factor := Factor * Factor;
Exp := Exp / 2;
end loop;
return Result;
else -- Exp < 0 then
-- For the negative exponent case, a constraint error during this
-- calculation happens if Factor gets too large, and the proper
-- response is to return 0.0, since what we essentially have is
-- 1.0 / infinity, and the closest model number will be zero.
begin
while Exp /= 0 loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Factor := Factor * Factor;
Exp := Exp / 2;
end loop;
return R ' (1.0) / Result;
exception
when Constraint_Error =>
return (0.0, 0.0);
end;
end if;
end "**";
function "**" (Left : Imaginary; Right : Integer) return Complex is
M : R := R (Left) ** Right;
begin
case Right mod 4 is
when 0 => return (M, 0.0);
when 1 => return (0.0, M);
when 2 => return (-M, 0.0);
when 3 => return (0.0, -M);
when others => raise Program_Error;
end case;
end "**";
---------
-- "+" --
---------
function "+" (Right : Complex) return Complex is
begin
return Right;
end "+";
function "+" (Left, Right : Complex) return Complex is
begin
return Complex'(Left.Re + Right.Re, Left.Im + Right.Im);
end "+";
function "+" (Right : Imaginary) return Imaginary is
begin
return Right;
end "+";
function "+" (Left, Right : Imaginary) return Imaginary is
begin
return Imaginary (R (Left) + R (Right));
end "+";
function "+" (Left : Complex; Right : Real'Base) return Complex is
begin
return Complex'(Left.Re + Right, Left.Im);
end "+";
function "+" (Left : Real'Base; Right : Complex) return Complex is
begin
return Complex'(Left + Right.Re, Right.Im);
end "+";
function "+" (Left : Complex; Right : Imaginary) return Complex is
begin
return Complex'(Left.Re, Left.Im + R (Right));
end "+";
function "+" (Left : Imaginary; Right : Complex) return Complex is
begin
return Complex'(Right.Re, R (Left) + Right.Im);
end "+";
function "+" (Left : Imaginary; Right : Real'Base) return Complex is
begin
return Complex'(Right, R (Left));
end "+";
function "+" (Left : Real'Base; Right : Imaginary) return Complex is
begin
return Complex'(Left, R (Right));
end "+";
---------
-- "-" --
---------
function "-" (Right : Complex) return Complex is
begin
return (-Right.Re, -Right.Im);
end "-";
function "-" (Left, Right : Complex) return Complex is
begin
return (Left.Re - Right.Re, Left.Im - Right.Im);
end "-";
function "-" (Right : Imaginary) return Imaginary is
begin
return Imaginary (-R (Right));
end "-";
function "-" (Left, Right : Imaginary) return Imaginary is
begin
return Imaginary (R (Left) - R (Right));
end "-";
function "-" (Left : Complex; Right : Real'Base) return Complex is
begin
return Complex'(Left.Re - Right, Left.Im);
end "-";
function "-" (Left : Real'Base; Right : Complex) return Complex is
begin
return Complex'(Left - Right.Re, -Right.Im);
end "-";
function "-" (Left : Complex; Right : Imaginary) return Complex is
begin
return Complex'(Left.Re, Left.Im - R (Right));
end "-";
function "-" (Left : Imaginary; Right : Complex) return Complex is
begin
return Complex'(-Right.Re, R (Left) - Right.Im);
end "-";
function "-" (Left : Imaginary; Right : Real'Base) return Complex is
begin
return Complex'(-Right, R (Left));
end "-";
function "-" (Left : Real'Base; Right : Imaginary) return Complex is
begin
return Complex'(Left, -R (Right));
end "-";
---------
-- "/" --
---------
function "/" (Left, Right : Complex) return Complex is
a : constant R := Left.Re;
b : constant R := Left.Im;
c : constant R := Right.Re;
d : constant R := Right.Im;
begin
if c = 0.0 and then d = 0.0 then
raise Constraint_Error;
else
return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2),
Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2));
end if;
end "/";
function "/" (Left, Right : Imaginary) return Real'Base is
begin
return R (Left) / R (Right);
end "/";
function "/" (Left : Complex; Right : Real'Base) return Complex is
begin
return Complex'(Left.Re / Right, Left.Im / Right);
end "/";
function "/" (Left : Real'Base; Right : Complex) return Complex is
a : constant R := Left;
c : constant R := Right.Re;
d : constant R := Right.Im;
begin
return Complex'(Re => (a * c) / (c ** 2 + d ** 2),
Im => -(a * d) / (c ** 2 + d ** 2));
end "/";
function "/" (Left : Complex; Right : Imaginary) return Complex is
a : constant R := Left.Re;
b : constant R := Left.Im;
d : constant R := R (Right);
begin
return (b / d, -a / d);
end "/";
function "/" (Left : Imaginary; Right : Complex) return Complex is
b : constant R := R (Left);
c : constant R := Right.Re;
d : constant R := Right.Im;
begin
return (Re => b * d / (c ** 2 + d ** 2),
Im => b * c / (c ** 2 + d ** 2));
end "/";
function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is
begin
return Imaginary (R (Left) / Right);
end "/";
function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is
begin
return Imaginary (-Left / R (Right));
end "/";
---------
-- "<" --
---------
function "<" (Left, Right : Imaginary) return Boolean is
begin
return R (Left) < R (Right);
end "<";
----------
-- "<=" --
----------
function "<=" (Left, Right : Imaginary) return Boolean is
begin
return R (Left) <= R (Right);
end "<=";
---------
-- ">" --
---------
function ">" (Left, Right : Imaginary) return Boolean is
begin
return R (Left) > R (Right);
end ">";
----------
-- ">=" --
----------
function ">=" (Left, Right : Imaginary) return Boolean is
begin
return R (Left) >= R (Right);
end ">=";
-----------
-- "abs" --
-----------
function "abs" (Right : Imaginary) return Real'Base is
begin
return abs R (Right);
end "abs";
--------------
-- Argument --
--------------
function Argument (X : Complex) return Real'Base is
a : constant R := X.Re;
b : constant R := X.Im;
arg : R;
begin
if b = 0.0 then
if a >= 0.0 then
return 0.0;
else
return R'Copy_Sign (Pi, b);
end if;
elsif a = 0.0 then
if b >= 0.0 then
return Half_Pi;
else
return -Half_Pi;
end if;
else
arg := R (Atan (Double (abs (b / a))));
if a > 0.0 then
if b > 0.0 then
return arg;
else -- b < 0.0
return -arg;
end if;
else -- a < 0.0
if b >= 0.0 then
return Pi - arg;
else -- b < 0.0
return -(Pi - arg);
end if;
end if;
end if;
exception
when Constraint_Error =>
if b > 0.0 then
return Half_Pi;
else
return -Half_Pi;
end if;
end Argument;
function Argument (X : Complex; Cycle : Real'Base) return Real'Base is
begin
if Cycle > 0.0 then
return Argument (X) * Cycle / Two_Pi;
else
raise Argument_Error;
end if;
end Argument;
----------------------------
-- Compose_From_Cartesian --
----------------------------
function Compose_From_Cartesian (Re, Im : Real'Base) return Complex is
begin
return (Re, Im);
end Compose_From_Cartesian;
function Compose_From_Cartesian (Re : Real'Base) return Complex is
begin
return (Re, 0.0);
end Compose_From_Cartesian;
function Compose_From_Cartesian (Im : Imaginary) return Complex is
begin
return (0.0, R (Im));
end Compose_From_Cartesian;
------------------------
-- Compose_From_Polar --
------------------------
function Compose_From_Polar (
Modulus, Argument : Real'Base)
return Complex
is
begin
if Modulus = 0.0 then
return (0.0, 0.0);
else
return (Modulus * R (Cos (Double (Argument))),
Modulus * R (Sin (Double (Argument))));
end if;
end Compose_From_Polar;
function Compose_From_Polar (
Modulus, Argument, Cycle : Real'Base)
return Complex
is
Arg : Real'Base;
begin
if Modulus = 0.0 then
return (0.0, 0.0);
elsif Cycle > 0.0 then
if Argument = 0.0 then
return (Modulus, 0.0);
elsif Argument = Cycle / 4.0 then
return (0.0, Modulus);
elsif Argument = Cycle / 2.0 then
return (-Modulus, 0.0);
elsif Argument = 3.0 * Cycle / R (4.0) then
return (0.0, -Modulus);
else
Arg := Two_Pi * Argument / Cycle;
return (Modulus * R (Cos (Double (Arg))),
Modulus * R (Sin (Double (Arg))));
end if;
else
raise Argument_Error;
end if;
end Compose_From_Polar;
---------------
-- Conjugate --
---------------
function Conjugate (X : Complex) return Complex is
begin
return Complex'(X.Re, -X.Im);
end Conjugate;
--------
-- Im --
--------
function Im (X : Complex) return Real'Base is
begin
return X.Im;
end Im;
function Im (X : Imaginary) return Real'Base is
begin
return R (X);
end Im;
-------------
-- Modulus --
-------------
function Modulus (X : Complex) return Real'Base is
Re2, Im2 : R;
begin
begin
Re2 := X.Re ** 2;
-- To compute (a**2 + b**2) ** (0.5) when a**2 may be out of bounds,
-- compute a * (1 + (b/a) **2) ** (0.5). On a machine where the
-- squaring does not raise constraint_error but generates infinity,
-- we can use an explicit comparison to determine whether to use
-- the scaling expression.
if Re2 > R'Last then
raise Constraint_Error;
end if;
exception
when Constraint_Error =>
return abs (X.Re)
* R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2)));
end;
begin
Im2 := X.Im ** 2;
if Im2 > R'Last then
raise Constraint_Error;
end if;
exception
when Constraint_Error =>
return abs (X.Im)
* R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2)));
end;
-- Now deal with cases of underflow. If only one of the squares
-- underflows, return the modulus of the other component. If both
-- squares underflow, use scaling as above.
if Re2 = 0.0 then
if X.Re = 0.0 then
return abs (X.Im);
elsif Im2 = 0.0 then
if X.Im = 0.0 then
return abs (X.Re);
else
if abs (X.Re) > abs (X.Im) then
return
abs (X.Re)
* R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2)));
else
return
abs (X.Im)
* R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2)));
end if;
end if;
else
return abs (X.Im);
end if;
elsif Im2 = 0.0 then
return abs (X.Re);
-- in all other cases, the naive computation will do.
else
return R (Sqrt (Double (Re2 + Im2)));
end if;
end Modulus;
--------
-- Re --
--------
function Re (X : Complex) return Real'Base is
begin
return X.Re;
end Re;
------------
-- Set_Im --
------------
procedure Set_Im (X : in out Complex; Im : in Real'Base) is
begin
X.Im := Im;
end Set_Im;
procedure Set_Im (X : out Imaginary; Im : in Real'Base) is
begin
X := Imaginary (Im);
end Set_Im;
------------
-- Set_Re --
------------
procedure Set_Re (X : in out Complex; Re : in Real'Base) is
begin
X.Re := Re;
end Set_Re;
end Ada.Numerics.Generic_Complex_Types;

161
gcc/ada/a-ngcoty.ads Normal file
View File

@ -0,0 +1,161 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
generic
type Real is digits <>;
package Ada.Numerics.Generic_Complex_Types is
pragma Pure (Generic_Complex_Types);
type Complex is record
Re, Im : Real'Base;
end record;
pragma Complex_Representation (Complex);
type Imaginary is private;
i : constant Imaginary;
j : constant Imaginary;
function Re (X : Complex) return Real'Base;
function Im (X : Complex) return Real'Base;
function Im (X : Imaginary) return Real'Base;
procedure Set_Re (X : in out Complex; Re : in Real'Base);
procedure Set_Im (X : in out Complex; Im : in Real'Base);
procedure Set_Im (X : out Imaginary; Im : in Real'Base);
function Compose_From_Cartesian (Re, Im : Real'Base) return Complex;
function Compose_From_Cartesian (Re : Real'Base) return Complex;
function Compose_From_Cartesian (Im : Imaginary) return Complex;
function Modulus (X : Complex) return Real'Base;
function "abs" (Right : Complex) return Real'Base renames Modulus;
function Argument (X : Complex) return Real'Base;
function Argument (X : Complex; Cycle : Real'Base) return Real'Base;
function Compose_From_Polar (
Modulus, Argument : Real'Base)
return Complex;
function Compose_From_Polar (
Modulus, Argument, Cycle : Real'Base)
return Complex;
function "+" (Right : Complex) return Complex;
function "-" (Right : Complex) return Complex;
function Conjugate (X : Complex) return Complex;
function "+" (Left, Right : Complex) return Complex;
function "-" (Left, Right : Complex) return Complex;
function "*" (Left, Right : Complex) return Complex;
function "/" (Left, Right : Complex) return Complex;
function "**" (Left : Complex; Right : Integer) return Complex;
function "+" (Right : Imaginary) return Imaginary;
function "-" (Right : Imaginary) return Imaginary;
function Conjugate (X : Imaginary) return Imaginary renames "-";
function "abs" (Right : Imaginary) return Real'Base;
function "+" (Left, Right : Imaginary) return Imaginary;
function "-" (Left, Right : Imaginary) return Imaginary;
function "*" (Left, Right : Imaginary) return Real'Base;
function "/" (Left, Right : Imaginary) return Real'Base;
function "**" (Left : Imaginary; Right : Integer) return Complex;
function "<" (Left, Right : Imaginary) return Boolean;
function "<=" (Left, Right : Imaginary) return Boolean;
function ">" (Left, Right : Imaginary) return Boolean;
function ">=" (Left, Right : Imaginary) return Boolean;
function "+" (Left : Complex; Right : Real'Base) return Complex;
function "+" (Left : Real'Base; Right : Complex) return Complex;
function "-" (Left : Complex; Right : Real'Base) return Complex;
function "-" (Left : Real'Base; Right : Complex) return Complex;
function "*" (Left : Complex; Right : Real'Base) return Complex;
function "*" (Left : Real'Base; Right : Complex) return Complex;
function "/" (Left : Complex; Right : Real'Base) return Complex;
function "/" (Left : Real'Base; Right : Complex) return Complex;
function "+" (Left : Complex; Right : Imaginary) return Complex;
function "+" (Left : Imaginary; Right : Complex) return Complex;
function "-" (Left : Complex; Right : Imaginary) return Complex;
function "-" (Left : Imaginary; Right : Complex) return Complex;
function "*" (Left : Complex; Right : Imaginary) return Complex;
function "*" (Left : Imaginary; Right : Complex) return Complex;
function "/" (Left : Complex; Right : Imaginary) return Complex;
function "/" (Left : Imaginary; Right : Complex) return Complex;
function "+" (Left : Imaginary; Right : Real'Base) return Complex;
function "+" (Left : Real'Base; Right : Imaginary) return Complex;
function "-" (Left : Imaginary; Right : Real'Base) return Complex;
function "-" (Left : Real'Base; Right : Imaginary) return Complex;
function "*" (Left : Imaginary; Right : Real'Base) return Imaginary;
function "*" (Left : Real'Base; Right : Imaginary) return Imaginary;
function "/" (Left : Imaginary; Right : Real'Base) return Imaginary;
function "/" (Left : Real'Base; Right : Imaginary) return Imaginary;
private
type Imaginary is new Real'Base;
i : constant Imaginary := 1.0;
j : constant Imaginary := 1.0;
pragma Inline ("+");
pragma Inline ("-");
pragma Inline ("*");
pragma Inline ("<");
pragma Inline ("<=");
pragma Inline (">");
pragma Inline (">=");
pragma Inline ("abs");
pragma Inline (Compose_From_Cartesian);
pragma Inline (Conjugate);
pragma Inline (Im);
pragma Inline (Re);
pragma Inline (Set_Im);
pragma Inline (Set_Re);
end Ada.Numerics.Generic_Complex_Types;

1051
gcc/ada/a-ngelfu.adb Normal file
View File

File diff suppressed because it is too large Load Diff

75
gcc/ada/a-ngelfu.ads Normal file
View File

@ -0,0 +1,75 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
generic
type Float_Type is digits <>;
package Ada.Numerics.Generic_Elementary_Functions is
pragma Pure (Generic_Elementary_Functions);
function Sqrt (X : Float_Type'Base) return Float_Type'Base;
function Log (X : Float_Type'Base) return Float_Type'Base;
function Log (X, Base : Float_Type'Base) return Float_Type'Base;
function Exp (X : Float_Type'Base) return Float_Type'Base;
function "**" (Left, Right : Float_Type'Base) return Float_Type'Base;
function Sin (X : Float_Type'Base) return Float_Type'Base;
function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Cos (X : Float_Type'Base) return Float_Type'Base;
function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Tan (X : Float_Type'Base) return Float_Type'Base;
function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Cot (X : Float_Type'Base) return Float_Type'Base;
function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Arcsin (X : Float_Type'Base) return Float_Type'Base;
function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Arccos (X : Float_Type'Base) return Float_Type'Base;
function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Arctan
(Y : Float_Type'Base;
X : Float_Type'Base := 1.0)
return Float_Type'Base;
function Arctan
(Y : Float_Type'Base;
X : Float_Type'Base := 1.0;
Cycle : Float_Type'Base)
return Float_Type'Base;
function Arccot
(X : Float_Type'Base;
Y : Float_Type'Base := 1.0)
return Float_Type'Base;
function Arccot
(X : Float_Type'Base;
Y : Float_Type'Base := 1.0;
Cycle : Float_Type'Base)
return Float_Type'Base;
function Sinh (X : Float_Type'Base) return Float_Type'Base;
function Cosh (X : Float_Type'Base) return Float_Type'Base;
function Tanh (X : Float_Type'Base) return Float_Type'Base;
function Coth (X : Float_Type'Base) return Float_Type'Base;
function Arcsinh (X : Float_Type'Base) return Float_Type'Base;
function Arccosh (X : Float_Type'Base) return Float_Type'Base;
function Arctanh (X : Float_Type'Base) return Float_Type'Base;
function Arccoth (X : Float_Type'Base) return Float_Type'Base;
end Ada.Numerics.Generic_Elementary_Functions;

23
gcc/ada/a-nlcefu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.LONG_COMPLEX.ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Long_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
package Ada.Numerics.Long_Complex_Elementary_Functions is
new Ada.Numerics.Generic_Complex_Elementary_Functions
(Ada.Numerics.Long_Complex_Types);

23
gcc/ada/a-nlcoty.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . L O N G _ C O M P L E X _ T Y P E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Complex_Types;
package Ada.Numerics.Long_Complex_Types is
new Ada.Numerics.Generic_Complex_Types (Long_Float);
pragma Pure (Long_Complex_Types);

23
gcc/ada/a-nlelfu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.LONG_ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;
package Ada.Numerics.Long_Elementary_Functions is
new Ada.Numerics.Generic_Elementary_Functions (Long_Float);
pragma Pure (Long_Elementary_Functions);

23
gcc/ada/a-nllcef.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.LONG_LONG_COMPLEX.ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Long_Long_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
package Ada.Numerics.Long_Long_Complex_Elementary_Functions is
new Ada.Numerics.Generic_Complex_Elementary_Functions
(Ada.Numerics.Long_Long_Complex_Types);

23
gcc/ada/a-nllcty.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . L O N G _ L O N G _ C O M P L E X _ T Y P E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Complex_Types;
package Ada.Numerics.Long_Long_Complex_Types is
new Ada.Numerics.Generic_Complex_Types (Long_Long_Float);
pragma Pure (Long_Long_Complex_Types);

23
gcc/ada/a-nllefu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.LONG_LONG_ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;
package Ada.Numerics.Long_Long_Elementary_Functions is
new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float);
pragma Pure (Long_Long_Elementary_Functions);

23
gcc/ada/a-nscefu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.SHORT.COMPLEX.ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Short_Complex_Types;
with Ada.Numerics.Generic_Complex_Elementary_Functions;
package Ada.Numerics.Short_Complex_Elementary_Functions is
new Ada.Numerics.Generic_Complex_Elementary_Functions
(Ada.Numerics.Short_Complex_Types);

23
gcc/ada/a-nscoty.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . S H O R T _ C O M P L E X _ T Y P E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Complex_Types;
package Ada.Numerics.Short_Complex_Types is
new Ada.Numerics.Generic_Complex_Types (Short_Float);
pragma Pure (Short_Complex_Types);

23
gcc/ada/a-nselfu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- ADA.NUMERICS.SHORT_ELEMENTARY_FUNCTIONS --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;
package Ada.Numerics.Short_Elementary_Functions is
new Ada.Numerics.Generic_Elementary_Functions (Short_Float);
pragma Pure (Short_Elementary_Functions);

23
gcc/ada/a-nucoty.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . C O M P L E X _ T Y P E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Complex_Types;
package Ada.Numerics.Complex_Types is
new Ada.Numerics.Generic_Complex_Types (Float);
pragma Pure (Complex_Types);

266
gcc/ada/a-nudira.adb Normal file
View File

@ -0,0 +1,266 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M --
-- --
-- B o d y --
-- --
-- $Revision: 1.17 $
-- --
-- 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. --
-- --
-- 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;
with Interfaces; use Interfaces;
package body Ada.Numerics.Discrete_Random is
-------------------------
-- Implementation Note --
-------------------------
-- The design of this spec is very awkward, as a result of Ada 95 not
-- permitting in-out parameters for function formals (most naturally
-- Generator values would be passed this way). In pure Ada 95, the only
-- solution is to use the heap and pointers, and, to avoid memory leaks,
-- controlled types.
-- This is awfully heavy, so what we do is to use Unrestricted_Access to
-- get a pointer to the state in the passed Generator. This works because
-- Generator is a limited type and will thus always be passed by reference.
type Pointer is access all State;
Need_64 : constant Boolean := Rst'Pos (Rst'Last) > Int'Last;
-----------------------
-- Local Subprograms --
-----------------------
function Square_Mod_N (X, N : Int) return Int;
pragma Inline (Square_Mod_N);
-- Computes X**2 mod N avoiding intermediate overflow
-----------
-- Image --
-----------
function Image (Of_State : State) return String is
begin
return Int'Image (Of_State.X1) &
',' &
Int'Image (Of_State.X2) &
',' &
Int'Image (Of_State.Q);
end Image;
------------
-- Random --
------------
function Random (Gen : Generator) return Rst is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
Temp : Int;
TF : Flt;
begin
-- Check for flat range here, since we are typically run with checks
-- off, note that in practice, this condition will usually be static
-- so we will not actually generate any code for the normal case.
if Rst'Last < Rst'First then
raise Constraint_Error;
end if;
-- Continue with computation if non-flat range
Genp.X1 := Square_Mod_N (Genp.X1, Genp.P);
Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q);
Temp := Genp.X2 - Genp.X1;
-- Following duplication is not an error, it is a loop unwinding!
if Temp < 0 then
Temp := Temp + Genp.Q;
end if;
if Temp < 0 then
Temp := Temp + Genp.Q;
end if;
TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl;
-- Pathological, but there do exist cases where the rounding implicit
-- in calculating the scale factor will cause rounding to 'Last + 1.
-- In those cases, returning 'First results in the least bias.
if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then
return Rst'First;
elsif Need_64 then
return Rst'Val (Interfaces.Integer_64 (TF));
else
return Rst'Val (Int (TF));
end if;
end Random;
-----------
-- Reset --
-----------
procedure Reset (Gen : Generator; Initiator : Integer) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
X1, X2 : Int;
begin
X1 := 2 + Int (Initiator) mod (K1 - 3);
X2 := 2 + Int (Initiator) mod (K2 - 3);
for J in 1 .. 5 loop
X1 := Square_Mod_N (X1, K1);
X2 := Square_Mod_N (X2, K2);
end loop;
-- eliminate effects of small Initiators.
Genp.all :=
(X1 => X1,
X2 => X2,
P => K1,
Q => K2,
FP => K1F,
Scl => Scal);
end Reset;
-----------
-- Reset --
-----------
procedure Reset (Gen : Generator) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
Now : constant Calendar.Time := Calendar.Clock;
X1 : Int;
X2 : Int;
begin
X1 := Int (Calendar.Year (Now)) * 12 * 31 +
Int (Calendar.Month (Now) * 31) +
Int (Calendar.Day (Now));
X2 := Int (Calendar.Seconds (Now) * Duration (1000.0));
X1 := 2 + X1 mod (K1 - 3);
X2 := 2 + X2 mod (K2 - 3);
-- Eliminate visible effects of same day starts
for J in 1 .. 5 loop
X1 := Square_Mod_N (X1, K1);
X2 := Square_Mod_N (X2, K2);
end loop;
Genp.all :=
(X1 => X1,
X2 => X2,
P => K1,
Q => K2,
FP => K1F,
Scl => Scal);
end Reset;
-----------
-- Reset --
-----------
procedure Reset (Gen : Generator; From_State : State) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
begin
Genp.all := From_State;
end Reset;
----------
-- Save --
----------
procedure Save (Gen : Generator; To_State : out State) is
begin
To_State := Gen.Gen_State;
end Save;
------------------
-- Square_Mod_N --
------------------
function Square_Mod_N (X, N : Int) return Int is
begin
return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N)));
end Square_Mod_N;
-----------
-- Value --
-----------
function Value (Coded_State : String) return State is
Start : Positive := Coded_State'First;
Stop : Positive := Coded_State'First;
Outs : State;
begin
while Coded_State (Stop) /= ',' loop
Stop := Stop + 1;
end loop;
Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1));
Start := Stop + 1;
loop
Stop := Stop + 1;
exit when Coded_State (Stop) = ',';
end loop;
Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1));
Outs.Q := Int'Value (Coded_State (Stop + 1 .. Coded_State'Last));
Outs.P := Outs.Q * 2 + 1;
Outs.FP := Flt (Outs.P);
Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q));
-- Now do *some* sanity checks.
if Outs.Q < 31
or else Outs.X1 not in 2 .. Outs.P - 1
or else Outs.X2 not in 2 .. Outs.Q - 1
then
raise Constraint_Error;
end if;
return Outs;
end Value;
end Ada.Numerics.Discrete_Random;

108
gcc/ada/a-nudira.ads Normal file
View File

@ -0,0 +1,108 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M --
-- --
-- S p e c --
-- --
-- $Revision: 1.13 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
-- Note: the implementation used in this package was contributed by
-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and
-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The
-- particular choices for P and Q chosen here guarantee a period of
-- 562,085,314,430,582 (about 2**49), and the generated sequence has
-- excellent randomness properties. For further details, see the
-- paper "Fast Generation of Trustworthy Random Numbers", by Robert
-- Eachus, which describes both the algorithm and the efficient
-- implementation approach used here.
with Interfaces;
generic
type Result_Subtype is (<>);
package Ada.Numerics.Discrete_Random is
-- Basic facilities.
type Generator is limited private;
function Random (Gen : Generator) return Result_Subtype;
procedure Reset (Gen : Generator);
procedure Reset (Gen : Generator; Initiator : Integer);
-- Advanced facilities.
type State is private;
procedure Save (Gen : Generator; To_State : out State);
procedure Reset (Gen : Generator; From_State : State);
Max_Image_Width : constant := 80;
function Image (Of_State : State) return String;
function Value (Coded_State : String) return State;
private
subtype Int is Interfaces.Integer_32;
subtype Rst is Result_Subtype;
type Flt is digits 14;
RstF : constant Flt := Flt (Rst'Pos (Rst'First));
RstL : constant Flt := Flt (Rst'Pos (Rst'Last));
Offs : constant Flt := RstF - 0.5;
K1 : constant := 94_833_359;
K1F : constant := 94_833_359.0;
K2 : constant := 47_416_679;
K2F : constant := 47_416_679.0;
Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F);
type State is record
X1 : Int := Int (2999 ** 2);
X2 : Int := Int (1439 ** 2);
P : Int := K1;
Q : Int := K2;
FP : Flt := K1F;
Scl : Flt := Scal;
end record;
type Generator is limited record
Gen_State : State;
end record;
end Ada.Numerics.Discrete_Random;

23
gcc/ada/a-nuelfu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . E L E M E N T A R Y _ F U N C T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;
package Ada.Numerics.Elementary_Functions is
new Ada.Numerics.Generic_Elementary_Functions (Float);
pragma Pure (Elementary_Functions);

302
gcc/ada/a-nuflra.adb Normal file
View File

@ -0,0 +1,302 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . F L O A T _ R A N D O M --
-- --
-- B o d y --
-- --
-- $Revision: 1.17 $ --
-- --
-- Copyright (C) 1992-1998, 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 Ada.Calendar;
package body Ada.Numerics.Float_Random is
-------------------------
-- Implementation Note --
-------------------------
-- The design of this spec is very awkward, as a result of Ada 95 not
-- permitting in-out parameters for function formals (most naturally
-- Generator values would be passed this way). In pure Ada 95, the only
-- solution is to use the heap and pointers, and, to avoid memory leaks,
-- controlled types.
-- This is awfully heavy, so what we do is to use Unrestricted_Access to
-- get a pointer to the state in the passed Generator. This works because
-- Generator is a limited type and will thus always be passed by reference.
type Pointer is access all State;
-----------------------
-- Local Subprograms --
-----------------------
procedure Euclid (P, Q : in Int; X, Y : out Int; GCD : out Int);
function Euclid (P, Q : Int) return Int;
function Square_Mod_N (X, N : Int) return Int;
------------
-- Euclid --
------------
procedure Euclid (P, Q : in Int; X, Y : out Int; GCD : out Int) is
XT : Int := 1;
YT : Int := 0;
procedure Recur
(P, Q : in Int; -- a (i-1), a (i)
X, Y : in Int; -- x (i), y (i)
XP, YP : in out Int; -- x (i-1), y (i-1)
GCD : out Int);
procedure Recur
(P, Q : in Int;
X, Y : in Int;
XP, YP : in out Int;
GCD : out Int)
is
Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _|
XT : Int := X; -- x (i)
YT : Int := Y; -- y (i)
begin
if P rem Q = 0 then -- while does not divide
GCD := Q;
XP := X;
YP := Y;
else
Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo);
-- a (i) <== a (i)
-- a (i+1) <-- a (i-1) - q*a (i)
-- x (i+1) <-- x (i-1) - q*x (i)
-- y (i+1) <-- y (i-1) - q*y (i)
-- x (i) <== x (i)
-- y (i) <== y (i)
XP := XT;
YP := YT;
GCD := Quo;
end if;
end Recur;
-- Start of processing for Euclid
begin
Recur (P, Q, 0, 1, XT, YT, GCD);
X := XT;
Y := YT;
end Euclid;
function Euclid (P, Q : Int) return Int is
X, Y, GCD : Int;
begin
Euclid (P, Q, X, Y, GCD);
return X;
end Euclid;
-----------
-- Image --
-----------
function Image (Of_State : State) return String is
begin
return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2)
& ',' &
Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q);
end Image;
------------
-- Random --
------------
function Random (Gen : Generator) return Uniformly_Distributed is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
begin
Genp.X1 := Square_Mod_N (Genp.X1, Genp.P);
Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q);
return
Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X)
mod Genp.Q) * Flt (Genp.P)
+ Flt (Genp.X1)) * Genp.Scl);
end Random;
-----------
-- Reset --
-----------
-- Version that works from given initiator value
procedure Reset (Gen : in Generator; Initiator : in Integer) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
X1, X2 : Int;
begin
X1 := 2 + Int (Initiator) mod (K1 - 3);
X2 := 2 + Int (Initiator) mod (K2 - 3);
-- Eliminate effects of small Initiators.
for J in 1 .. 5 loop
X1 := Square_Mod_N (X1, K1);
X2 := Square_Mod_N (X2, K2);
end loop;
Genp.all :=
(X1 => X1,
X2 => X2,
P => K1,
Q => K2,
X => 1,
Scl => Scal);
end Reset;
-- Version that works from specific saved state
procedure Reset (Gen : Generator; From_State : State) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
begin
Genp.all := From_State;
end Reset;
-- Version that works from calendar
procedure Reset (Gen : Generator) is
Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
Now : constant Calendar.Time := Calendar.Clock;
X1, X2 : Int;
begin
X1 := Int (Calendar.Year (Now)) * 12 * 31 +
Int (Calendar.Month (Now)) * 31 +
Int (Calendar.Day (Now));
X2 := Int (Calendar.Seconds (Now) * Duration (1000.0));
X1 := 2 + X1 mod (K1 - 3);
X2 := 2 + X2 mod (K2 - 3);
-- Eliminate visible effects of same day starts
for J in 1 .. 5 loop
X1 := Square_Mod_N (X1, K1);
X2 := Square_Mod_N (X2, K2);
end loop;
Genp.all :=
(X1 => X1,
X2 => X2,
P => K1,
Q => K2,
X => 1,
Scl => Scal);
end Reset;
----------
-- Save --
----------
procedure Save (Gen : in Generator; To_State : out State) is
begin
To_State := Gen.Gen_State;
end Save;
------------------
-- Square_Mod_N --
------------------
function Square_Mod_N (X, N : Int) return Int is
Temp : Flt := Flt (X) * Flt (X);
Div : Int := Int (Temp / Flt (N));
begin
Div := Int (Temp - Flt (Div) * Flt (N));
if Div < 0 then
return Div + N;
else
return Div;
end if;
end Square_Mod_N;
-----------
-- Value --
-----------
function Value (Coded_State : String) return State is
Start : Positive := Coded_State'First;
Stop : Positive := Coded_State'First;
Outs : State;
begin
while Coded_State (Stop) /= ',' loop
Stop := Stop + 1;
end loop;
Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1));
Start := Stop + 1;
loop
Stop := Stop + 1;
exit when Coded_State (Stop) = ',';
end loop;
Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1));
Start := Stop + 1;
loop
Stop := Stop + 1;
exit when Coded_State (Stop) = ',';
end loop;
Outs.P := Int'Value (Coded_State (Start .. Stop - 1));
Outs.Q := Int'Value (Coded_State (Stop + 1 .. Coded_State'Last));
Outs.X := Euclid (Outs.P, Outs.Q);
Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q));
-- Now do *some* sanity checks.
if Outs.Q < 31 or else Outs.P < 31
or else Outs.X1 not in 2 .. Outs.P - 1
or else Outs.X2 not in 2 .. Outs.Q - 1
then
raise Constraint_Error;
end if;
return Outs;
end Value;
end Ada.Numerics.Float_Random;

101
gcc/ada/a-nuflra.ads Normal file
View File

@ -0,0 +1,101 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . F L O A T _ R A N D O M --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $ --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
-- Note: the implementation used in this package was contributed by
-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and
-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The
-- particular choices for P and Q chosen here guarantee a period of
-- 562,085,314,430,582 (about 2**49), and the generated sequence has
-- excellent randomness properties. For further details, see the
-- paper "Fast Generation of Trustworthy Random Numbers", by Robert
-- Eachus, which describes both the algorithm and the efficient
-- implementation approach used here. This paper is available at
-- the Ada Core Technologies web site (http://www.gnat.com).
with Interfaces;
package Ada.Numerics.Float_Random is
-- Basic facilities
type Generator is limited private;
subtype Uniformly_Distributed is Float range 0.0 .. 1.0;
function Random (Gen : Generator) return Uniformly_Distributed;
procedure Reset (Gen : Generator);
procedure Reset (Gen : Generator; Initiator : Integer);
-- Advanced facilities
type State is private;
procedure Save (Gen : Generator; To_State : out State);
procedure Reset (Gen : Generator; From_State : State);
Max_Image_Width : constant := 80;
function Image (Of_State : State) return String;
function Value (Coded_State : String) return State;
private
type Int is new Interfaces.Integer_32;
type Flt is digits 14;
K1 : constant := 94_833_359;
K1F : constant := 94_833_359.0;
K2 : constant := 47_416_679;
K2F : constant := 47_416_679.0;
Scal : constant := 1.0 / (K1F * K2F);
type State is record
X1 : Int := 2999 ** 2; -- Square mod p
X2 : Int := 1439 ** 2; -- Square mod q
P : Int := K1;
Q : Int := K2;
X : Int := 1;
Scl : Flt := Scal;
end record;
type Generator is limited record
Gen_State : State;
end record;
end Ada.Numerics.Float_Random;

98
gcc/ada/a-numaux.ads Normal file
View File

@ -0,0 +1,98 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- S p e c --
-- (C Library Version, non-x86) --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (C) 1992-1998 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 provides the basic computational interface for the generic
-- elementary functions. The C library version interfaces with the routines
-- in the C mathematical library, and is thus quite portable, although it may
-- not necessarily meet the requirements for accuracy in the numerics annex.
-- One advantage of using this package is that it will interface directly to
-- hardware instructions, such as the those provided on the Intel x86.
-- Note: there are two versions of this package. One using the normal IEEE
-- 64-bit double format (which is this version), and one using 80-bit x86
-- long double (see file 4onumaux.ads).
package Ada.Numerics.Aux is
pragma Pure (Aux);
pragma Linker_Options ("-lm");
type Double is digits 15;
pragma Float_Representation (IEEE_Float, Double);
-- Type Double is the type used to call the C routines. Note that this
-- is IEEE format even when running on VMS with Vax_Float representation
-- since we use the IEEE version of the C library with VMS.
function Sin (X : Double) return Double;
pragma Import (C, Sin, "sin");
function Cos (X : Double) return Double;
pragma Import (C, Cos, "cos");
function Tan (X : Double) return Double;
pragma Import (C, Tan, "tan");
function Exp (X : Double) return Double;
pragma Import (C, Exp, "exp");
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "sqrt");
function Log (X : Double) return Double;
pragma Import (C, Log, "log");
function Acos (X : Double) return Double;
pragma Import (C, Acos, "acos");
function Asin (X : Double) return Double;
pragma Import (C, Asin, "asin");
function Atan (X : Double) return Double;
pragma Import (C, Atan, "atan");
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "sinh");
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "cosh");
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "tanh");
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "pow");
end Ada.Numerics.Aux;

30
gcc/ada/a-numeri.ads Normal file
View File

@ -0,0 +1,30 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.Numerics is
pragma Pure (Numerics);
Argument_Error : exception;
Pi : constant :=
3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511;
e : constant :=
2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996;
end Ada.Numerics;

208
gcc/ada/a-reatim.adb Normal file
View File

@ -0,0 +1,208 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . R E A L _ T I M E --
-- --
-- B o d y --
-- --
-- $Revision: 1.34 $
-- --
-- Copyright (C) 1991-2001, Florida State University --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
-- used for Monotonic_Clock
package body Ada.Real_Time is
---------
-- "*" --
---------
-- Note that Constraint_Error may be propagated
function "*" (Left : Time_Span; Right : Integer) return Time_Span is
begin
return Time_Span (Duration (Left) * Right);
end "*";
function "*" (Left : Integer; Right : Time_Span) return Time_Span is
begin
return Time_Span (Left * Duration (Right));
end "*";
---------
-- "+" --
---------
-- Note that Constraint_Error may be propagated
function "+" (Left : Time; Right : Time_Span) return Time is
begin
return Time (Duration (Left) + Duration (Right));
end "+";
function "+" (Left : Time_Span; Right : Time) return Time is
begin
return Time (Duration (Left) + Duration (Right));
end "+";
function "+" (Left, Right : Time_Span) return Time_Span is
begin
return Time_Span (Duration (Left) + Duration (Right));
end "+";
---------
-- "-" --
---------
-- Note that Constraint_Error may be propagated
function "-" (Left : Time; Right : Time_Span) return Time is
begin
return Time (Duration (Left) - Duration (Right));
end "-";
function "-" (Left, Right : Time) return Time_Span is
begin
return Time_Span (Duration (Left) - Duration (Right));
end "-";
function "-" (Left, Right : Time_Span) return Time_Span is
begin
return Time_Span (Duration (Left) - Duration (Right));
end "-";
function "-" (Right : Time_Span) return Time_Span is
begin
return Time_Span_Zero - Right;
end "-";
---------
-- "/" --
---------
-- Note that Constraint_Error may be propagated
function "/" (Left, Right : Time_Span) return Integer is
begin
return Integer (Duration (Left) / Duration (Right));
end "/";
function "/" (Left : Time_Span; Right : Integer) return Time_Span is
begin
return Time_Span (Duration (Left) / Right);
end "/";
-----------
-- Clock --
-----------
function Clock return Time is
begin
return Time (System.Task_Primitives.Operations.Monotonic_Clock);
end Clock;
------------------
-- Microseconds --
------------------
function Microseconds (US : Integer) return Time_Span is
begin
return Time_Span_Unit * US * 1_000;
end Microseconds;
------------------
-- Milliseconds --
------------------
function Milliseconds (MS : Integer) return Time_Span is
begin
return Time_Span_Unit * MS * 1_000_000;
end Milliseconds;
-----------------
-- Nanoseconds --
-----------------
function Nanoseconds (NS : Integer) return Time_Span is
begin
return Time_Span_Unit * NS;
end Nanoseconds;
-----------
-- Split --
-----------
procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
begin
-- Extract the integer part of T
if T = 0.0 then
SC := 0;
else
SC := Seconds_Count (Time_Span'(T - 0.5));
end if;
-- Since we loose precision when converting a time value to float,
-- we need to add this check
if Time (SC) > T then
SC := SC - 1;
end if;
TS := T - Time (SC);
end Split;
-------------
-- Time_Of --
-------------
function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
begin
return Time (SC) + TS;
end Time_Of;
-----------------
-- To_Duration --
-----------------
function To_Duration (TS : Time_Span) return Duration is
begin
return Duration (TS);
end To_Duration;
------------------
-- To_Time_Span --
------------------
function To_Time_Span (D : Duration) return Time_Span is
begin
return Time_Span (D);
end To_Time_Span;
end Ada.Real_Time;

126
gcc/ada/a-reatim.ads Normal file
View File

@ -0,0 +1,126 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . R E A L _ T I M E --
-- --
-- S p e c --
-- --
-- $Revision: 1.24 $ --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, 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 System.Task_Primitives.Operations;
pragma Elaborate_All (System.Task_Primitives.Operations);
package Ada.Real_Time is
type Time is private;
Time_First : constant Time;
Time_Last : constant Time;
Time_Unit : constant := 10#1.0#E-9;
type Time_Span is private;
Time_Span_First : constant Time_Span;
Time_Span_Last : constant Time_Span;
Time_Span_Zero : constant Time_Span;
Time_Span_Unit : constant Time_Span;
Tick : constant Time_Span;
function Clock return Time;
function "+" (Left : Time; Right : Time_Span) return Time;
function "+" (Left : Time_Span; Right : Time) return Time;
function "-" (Left : Time; Right : Time_Span) return Time;
function "-" (Left : Time; Right : Time) return Time_Span;
function "<" (Left, Right : Time) return Boolean;
function "<=" (Left, Right : Time) return Boolean;
function ">" (Left, Right : Time) return Boolean;
function ">=" (Left, Right : Time) return Boolean;
function "+" (Left, Right : Time_Span) return Time_Span;
function "-" (Left, Right : Time_Span) return Time_Span;
function "-" (Right : Time_Span) return Time_Span;
function "*" (Left : Time_Span; Right : Integer) return Time_Span;
function "*" (Left : Integer; Right : Time_Span) return Time_Span;
function "/" (Left, Right : Time_Span) return Integer;
function "/" (Left : Time_Span; Right : Integer) return Time_Span;
function "abs" (Right : Time_Span) return Time_Span;
function "<" (Left, Right : Time_Span) return Boolean;
function "<=" (Left, Right : Time_Span) return Boolean;
function ">" (Left, Right : Time_Span) return Boolean;
function ">=" (Left, Right : Time_Span) return Boolean;
function To_Duration (TS : Time_Span) return Duration;
function To_Time_Span (D : Duration) return Time_Span;
function Nanoseconds (NS : Integer) return Time_Span;
function Microseconds (US : Integer) return Time_Span;
function Milliseconds (MS : Integer) return Time_Span;
type Seconds_Count is new Integer range -Integer'Last .. Integer'Last;
procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span);
function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time;
private
type Time is new Duration;
Time_First : constant Time := Time'First;
Time_Last : constant Time := Time'Last;
type Time_Span is new Duration;
Time_Span_First : constant Time_Span := Time_Span'First;
Time_Span_Last : constant Time_Span := Time_Span'Last;
Time_Span_Zero : constant Time_Span := 0.0;
Time_Span_Unit : constant Time_Span := 10#1.0#E-9;
Tick : constant Time_Span :=
Time_Span (System.Task_Primitives.Operations.RT_Resolution);
-- Time and Time_Span are represented in 64-bit Duration value in
-- in nanoseconds. For example, 1 second and 1 nanosecond is
-- represented as the stored integer 1_000_000_001.
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "abs");
end Ada.Real_Time;

66
gcc/ada/a-retide.adb Normal file
View File

@ -0,0 +1,66 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . R E A L _ T I M E . D E L A Y S --
-- --
-- B o d y --
-- --
-- $Revision: 1.28 $
-- --
-- Copyright (C) 1991-1999 Florida State University --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
-- Used for Timed_Delay
with System.OS_Primitives;
-- Used for Delay_Modes
package body Ada.Real_Time.Delays is
package STPO renames System.Task_Primitives.Operations;
package OSP renames System.OS_Primitives;
-----------------
-- Delay_Until --
-----------------
procedure Delay_Until (T : Time) is
begin
STPO.Timed_Delay (STPO.Self, To_Duration (T), OSP.Absolute_RT);
end Delay_Until;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : Time) return Duration is
begin
return To_Duration (Time_Span (T));
end To_Duration;
end Ada.Real_Time.Delays;

52
gcc/ada/a-retide.ads Normal file
View File

@ -0,0 +1,52 @@
-------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . R E A L _ T I M E . D E L A Y S --
-- --
-- S p e c --
-- --
-- $Revision: 1.19 $
-- --
-- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
-- --
-- GNARL 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. GNARL 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 GNARL; 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. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Implements Real_Time.Time absolute delays
-- Note: the compiler generates direct calls to this interface, in the
-- processing of time types.
package Ada.Real_Time.Delays is
function To_Duration (T : Real_Time.Time) return Duration;
procedure Delay_Until (T : Time);
-- Delay until Clock has reached (at least) time T,
-- or the task is aborted to at least the current ATC nesting level.
-- The body of this procedure must perform all the processing
-- required for an abortion point.
end Ada.Real_Time.Delays;

266
gcc/ada/a-sequio.adb Normal file
View File

@ -0,0 +1,266 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S E Q U E N T I A L _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- 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. --
-- --
-- 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 generic template for Sequential_IO, i.e. the code that gets
-- duplicated. We absolutely minimize this code by either calling routines
-- in System.File_IO (for common file functions), or in System.Sequential_IO
-- (for specialized Sequential_IO functions)
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System;
with System.File_Control_Block;
with System.File_IO;
with System.Storage_Elements;
with Unchecked_Conversion;
package body Ada.Sequential_IO is
package FIO renames System.File_IO;
package FCB renames System.File_Control_Block;
package SIO renames System.Sequential_IO;
package SSE renames System.Storage_Elements;
SU : constant := System.Storage_Unit;
subtype AP is FCB.AFCB_Ptr;
subtype FP is SIO.File_Type;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
-----------
-- Close --
-----------
procedure Close (File : in out File_Type) is
begin
FIO.Close (AP (File));
end Close;
------------
-- Create --
------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Out_File;
Name : in String := "";
Form : in String := "")
is
begin
SIO.Create (FP (File), To_FCB (Mode), Name, Form);
end Create;
------------
-- Delete --
------------
procedure Delete (File : in out File_Type) is
begin
FIO.Delete (AP (File));
end Delete;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : in File_Type) return Boolean is
begin
return FIO.End_Of_File (AP (File));
end End_Of_File;
----------
-- Form --
----------
function Form (File : in File_Type) return String is
begin
return FIO.Form (AP (File));
end Form;
-------------
-- Is_Open --
-------------
function Is_Open (File : in File_Type) return Boolean is
begin
return FIO.Is_Open (AP (File));
end Is_Open;
----------
-- Mode --
----------
function Mode (File : in File_Type) return File_Mode is
begin
return To_SIO (FIO.Mode (AP (File)));
end Mode;
----------
-- Name --
----------
function Name (File : in File_Type) return String is
begin
return FIO.Name (AP (File));
end Name;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "")
is
begin
SIO.Open (FP (File), To_FCB (Mode), Name, Form);
end Open;
----------
-- Read --
----------
procedure Read (File : in File_Type; Item : out Element_Type) is
Siz : constant size_t := (Item'Size + SU - 1) / SU;
Rsiz : size_t;
begin
FIO.Check_Read_Status (AP (File));
-- For non-definite type or type with discriminants, read size and
-- raise Program_Error if it is larger than the size of the item.
if not Element_Type'Definite
or else Element_Type'Has_Discriminants
then
FIO.Read_Buf
(AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit);
-- For a type with discriminants, we have to read into a temporary
-- buffer if Item is constrained, to check that the discriminants
-- are correct.
pragma Extensions_Allowed (On);
-- Needed to allow Constrained reference here
if Element_Type'Has_Discriminants
and then Item'Constrained
then
declare
RsizS : constant SSE.Storage_Offset :=
SSE.Storage_Offset (Rsiz - 1);
subtype SA is SSE.Storage_Array (0 .. RsizS);
type SAP is access all SA;
type ItemP is access all Element_Type;
pragma Warnings (Off);
-- We have to turn warnings off for this function, because
-- it gets analyzed for all types, including ones which
-- can't possibly come this way, and for which the size
-- of the access types differs.
function To_ItemP is new Unchecked_Conversion (SAP, ItemP);
pragma Warnings (On);
Buffer : aliased SA;
pragma Unsuppress (Discriminant_Check);
begin
FIO.Read_Buf (AP (File), Buffer'Address, Rsiz);
Item := To_ItemP (Buffer'Access).all;
return;
end;
end if;
-- In the case of a non-definite type, make sure the length is OK.
-- We can't do this in the variant record case, because the size is
-- based on the current discriminant, so may be apparently wrong.
if not Element_Type'Has_Discriminants and then Rsiz > Siz then
raise Program_Error;
end if;
FIO.Read_Buf (AP (File), Item'Address, Rsiz);
-- For definite type without discriminants, use actual size of item
else
FIO.Read_Buf (AP (File), Item'Address, Siz);
end if;
end Read;
-----------
-- Reset --
-----------
procedure Reset (File : in out File_Type; Mode : in File_Mode) is
begin
FIO.Reset (AP (File), To_FCB (Mode));
end Reset;
procedure Reset (File : in out File_Type) is
begin
FIO.Reset (AP (File));
end Reset;
-----------
-- Write --
-----------
procedure Write (File : in File_Type; Item : in Element_Type) is
Siz : constant size_t := (Item'Size + SU - 1) / SU;
begin
FIO.Check_Write_Status (AP (File));
-- For non-definite types or types with discriminants, write the size
if not Element_Type'Definite
or else Element_Type'Has_Discriminants
then
FIO.Write_Buf
(AP (File), Siz'Address, size_t'Size / System.Storage_Unit);
end if;
FIO.Write_Buf (AP (File), Item'Address, Siz);
end Write;
end Ada.Sequential_IO;

128
gcc/ada/a-sequio.ads Normal file
View File

@ -0,0 +1,128 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S E Q U E N T I A L _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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.IO_Exceptions;
with System.Sequential_IO;
generic
type Element_Type (<>) is private;
package Ada.Sequential_IO is
type File_Type is limited private;
type File_Mode is (In_File, Out_File, Append_File);
-- The following representation clause allows the use of unchecked
-- conversion for rapid translation between the File_Mode type
-- used in this package and System.File_IO.
for File_Mode use
(In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File)
Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File)
Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File)
---------------------
-- File management --
---------------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Out_File;
Name : in String := "";
Form : in String := "");
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "");
procedure Close (File : in out File_Type);
procedure Delete (File : in out File_Type);
procedure Reset (File : in out File_Type; Mode : in File_Mode);
procedure Reset (File : in out File_Type);
function Mode (File : in File_Type) return File_Mode;
function Name (File : in File_Type) return String;
function Form (File : in File_Type) return String;
function Is_Open (File : in File_Type) return Boolean;
---------------------------------
-- Input and output operations --
---------------------------------
procedure Read (File : in File_Type; Item : out Element_Type);
procedure Write (File : in File_Type; Item : in Element_Type);
function End_Of_File (File : in File_Type) return Boolean;
----------------
-- Exceptions --
----------------
Status_Error : exception renames IO_Exceptions.Status_Error;
Mode_Error : exception renames IO_Exceptions.Mode_Error;
Name_Error : exception renames IO_Exceptions.Name_Error;
Use_Error : exception renames IO_Exceptions.Use_Error;
Device_Error : exception renames IO_Exceptions.Device_Error;
End_Error : exception renames IO_Exceptions.End_Error;
Data_Error : exception renames IO_Exceptions.Data_Error;
private
type File_Type is new System.Sequential_IO.File_Type;
-- All subprograms are inlined
pragma Inline (Close);
pragma Inline (Create);
pragma Inline (Delete);
pragma Inline (End_Of_File);
pragma Inline (Form);
pragma Inline (Is_Open);
pragma Inline (Mode);
pragma Inline (Name);
pragma Inline (Open);
pragma Inline (Read);
pragma Inline (Reset);
pragma Inline (Write);
end Ada.Sequential_IO;

21
gcc/ada/a-sfteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ F L O A T _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Short_Float_Text_IO is
new Ada.Text_IO.Float_IO (Short_Float);

21
gcc/ada/a-sfwtio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ F L O A T _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Short_Float_Wide_Text_IO is
new Ada.Wide_Text_IO.Float_IO (Short_Float);

86
gcc/ada/a-siocst.adb Normal file
View File

@ -0,0 +1,86 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1992-1998 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 Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO;
with System.File_Control_Block;
with System.Sequential_IO;
with Unchecked_Conversion;
package body Ada.Sequential_IO.C_Streams is
package FIO renames System.File_IO;
package FCB renames System.File_Control_Block;
package SIO renames System.Sequential_IO;
subtype AP is FCB.AFCB_Ptr;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
--------------
-- C_Stream --
--------------
function C_Stream (F : File_Type) return FILEs is
begin
FIO.Check_File_Open (AP (F));
return F.Stream;
end C_Stream;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in FILEs;
Form : in String := "")
is
File_Control_Block : SIO.Sequential_AFCB;
begin
FIO.Open (File_Ptr => AP (File),
Dummy_FCB => File_Control_Block,
Mode => To_FCB (Mode),
Name => "",
Form => Form,
Amethod => 'Q',
Creat => False,
Text => False,
C_Stream => C_Stream);
end Open;
end Ada.Sequential_IO.C_Streams;

57
gcc/ada/a-siocst.ads Normal file
View File

@ -0,0 +1,57 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- 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. --
-- --
-- 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 between Ada.Sequential_IO and the
-- C streams. This allows sharing of a stream between Ada and C or C++,
-- as well as allowing the Ada program to operate directly on the stream.
with Interfaces.C_Streams;
generic
package Ada.Sequential_IO.C_Streams is
package ICS renames Interfaces.C_Streams;
function C_Stream (F : File_Type) return ICS.FILEs;
-- Obtain stream from existing open file
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in ICS.FILEs;
Form : in String := "");
-- Create new file from existing stream
end Ada.Sequential_IO.C_Streams;

21
gcc/ada/a-siteio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ I N T E G E R _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Short_Integer_Text_IO is
new Ada.Text_IO.Integer_IO (Short_Integer);

21
gcc/ada/a-siwtio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Short_Integer_Wide_Text_IO is
new Ada.Wide_Text_IO.Integer_IO (Short_Integer);

84
gcc/ada/a-ssicst.adb Normal file
View File

@ -0,0 +1,84 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992-1998 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 Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO;
with System.File_Control_Block;
with Unchecked_Conversion;
package body Ada.Streams.Stream_IO.C_Streams is
package FIO renames System.File_IO;
package FCB renames System.File_Control_Block;
subtype AP is FCB.AFCB_Ptr;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
--------------
-- C_Stream --
--------------
function C_Stream (F : File_Type) return FILEs is
begin
FIO.Check_File_Open (AP (F));
return F.Stream;
end C_Stream;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in FILEs;
Form : in String := "")
is
File_Control_Block : Stream_AFCB;
begin
FIO.Open (File_Ptr => AP (File),
Dummy_FCB => File_Control_Block,
Mode => To_FCB (Mode),
Name => "",
Form => Form,
Amethod => 'S',
Creat => False,
Text => False,
C_Stream => C_Stream);
end Open;
end Ada.Streams.Stream_IO.C_Streams;

56
gcc/ada/a-ssicst.ads Normal file
View File

@ -0,0 +1,56 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- 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. --
-- --
-- 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 between Ada.Stream_IO and the
-- C streams. This allows sharing of a stream between Ada and C or C++,
-- as well as allowing the Ada program to operate directly on the stream.
with Interfaces.C_Streams;
package Ada.Streams.Stream_IO.C_Streams is
package ICS renames Interfaces.C_Streams;
function C_Stream (F : File_Type) return ICS.FILEs;
-- Obtain stream from existing open file
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
C_Stream : in ICS.FILEs;
Form : in String := "");
-- Create new file from existing stream
end Ada.Streams.Stream_IO.C_Streams;

21
gcc/ada/a-ssitio.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ S H O R T _ I N T E G E R _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
package Ada.Short_Short_Integer_Text_IO is
new Ada.Text_IO.Integer_IO (Short_Short_Integer);

21
gcc/ada/a-ssiwti.ads Normal file
View File

@ -0,0 +1,21 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO;
package Ada.Short_Short_Integer_Wide_Text_IO is
new Ada.Wide_Text_IO.Integer_IO (Short_Short_Integer);

918
gcc/ada/a-stmaco.ads Normal file
View File

@ -0,0 +1,918 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R I N G S . M A P S . C O N S T A N T S --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, 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.Characters.Latin_1;
package Ada.Strings.Maps.Constants is
pragma Preelaborate (Constants);
Control_Set : constant Character_Set;
Graphic_Set : constant Character_Set;
Letter_Set : constant Character_Set;
Lower_Set : constant Character_Set;
Upper_Set : constant Character_Set;
Basic_Set : constant Character_Set;
Decimal_Digit_Set : constant Character_Set;
Hexadecimal_Digit_Set : constant Character_Set;
Alphanumeric_Set : constant Character_Set;
Special_Set : constant Character_Set;
ISO_646_Set : constant Character_Set;
Lower_Case_Map : constant Character_Mapping;
-- Maps to lower case for letters, else identity
Upper_Case_Map : constant Character_Mapping;
-- Maps to upper case for letters, else identity
Basic_Map : constant Character_Mapping;
-- Maps to basic letters for letters, else identity
private
package L renames Ada.Characters.Latin_1;
Control_Set : constant Character_Set :=
(L.NUL .. L.US => True,
L.DEL .. L.APC => True,
others => False);
Graphic_Set : constant Character_Set :=
(L.Space .. L.Tilde => True,
L.No_Break_Space .. L.LC_Y_Diaeresis => True,
others => False);
Letter_Set : constant Character_Set :=
('A' .. 'Z' => True,
L.LC_A .. L.LC_Z => True,
L.UC_A_Grave .. L.UC_O_Diaeresis => True,
L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True,
L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True,
others => False);
Lower_Set : constant Character_Set :=
(L.LC_A .. L.LC_Z => True,
L.LC_German_Sharp_S .. L.LC_O_Diaeresis => True,
L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True,
others => False);
Upper_Set : constant Character_Set :=
('A' .. 'Z' => True,
L.UC_A_Grave .. L.UC_O_Diaeresis => True,
L.UC_O_Oblique_Stroke .. L.UC_Icelandic_Thorn => True,
others => False);
Basic_Set : constant Character_Set :=
('A' .. 'Z' => True,
L.LC_A .. L.LC_Z => True,
L.UC_AE_Diphthong .. L.UC_AE_Diphthong => True,
L.LC_AE_Diphthong .. L.LC_AE_Diphthong => True,
L.LC_German_Sharp_S .. L.LC_German_Sharp_S => True,
L.UC_Icelandic_Thorn .. L.UC_Icelandic_Thorn => True,
L.LC_Icelandic_Thorn .. L.LC_Icelandic_Thorn => True,
L.UC_Icelandic_Eth .. L.UC_Icelandic_Eth => True,
L.LC_Icelandic_Eth .. L.LC_Icelandic_Eth => True,
others => False);
Decimal_Digit_Set : constant Character_Set :=
('0' .. '9' => True,
others => False);
Hexadecimal_Digit_Set : constant Character_Set :=
('0' .. '9' => True,
'A' .. 'F' => True,
L.LC_A .. L.LC_F => True,
others => False);
Alphanumeric_Set : constant Character_Set :=
('0' .. '9' => True,
'A' .. 'Z' => True,
L.LC_A .. L.LC_Z => True,
L.UC_A_Grave .. L.UC_O_Diaeresis => True,
L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True,
L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True,
others => False);
Special_Set : constant Character_Set :=
(L.Space .. L.Solidus => True,
L.Colon .. L.Commercial_At => True,
L.Left_Square_Bracket .. L.Grave => True,
L.Left_Curly_Bracket .. L.Tilde => True,
L.No_Break_Space .. L.Inverted_Question => True,
L.Multiplication_Sign .. L.Multiplication_Sign => True,
L.Division_Sign .. L.Division_Sign => True,
others => False);
ISO_646_Set : constant Character_Set :=
(L.NUL .. L.DEL => True,
others => False);
Lower_Case_Map : constant Character_Mapping :=
(L.NUL & -- NUL 0
L.SOH & -- SOH 1
L.STX & -- STX 2
L.ETX & -- ETX 3
L.EOT & -- EOT 4
L.ENQ & -- ENQ 5
L.ACK & -- ACK 6
L.BEL & -- BEL 7
L.BS & -- BS 8
L.HT & -- HT 9
L.LF & -- LF 10
L.VT & -- VT 11
L.FF & -- FF 12
L.CR & -- CR 13
L.SO & -- SO 14
L.SI & -- SI 15
L.DLE & -- DLE 16
L.DC1 & -- DC1 17
L.DC2 & -- DC2 18
L.DC3 & -- DC3 19
L.DC4 & -- DC4 20
L.NAK & -- NAK 21
L.SYN & -- SYN 22
L.ETB & -- ETB 23
L.CAN & -- CAN 24
L.EM & -- EM 25
L.SUB & -- SUB 26
L.ESC & -- ESC 27
L.FS & -- FS 28
L.GS & -- GS 29
L.RS & -- RS 30
L.US & -- US 31
L.Space & -- ' ' 32
L.Exclamation & -- '!' 33
L.Quotation & -- '"' 34
L.Number_Sign & -- '#' 35
L.Dollar_Sign & -- '$' 36
L.Percent_Sign & -- '%' 37
L.Ampersand & -- '&' 38
L.Apostrophe & -- ''' 39
L.Left_Parenthesis & -- '(' 40
L.Right_Parenthesis & -- ')' 41
L.Asterisk & -- '*' 42
L.Plus_Sign & -- '+' 43
L.Comma & -- ',' 44
L.Hyphen & -- '-' 45
L.Full_Stop & -- '.' 46
L.Solidus & -- '/' 47
'0' & -- '0' 48
'1' & -- '1' 49
'2' & -- '2' 50
'3' & -- '3' 51
'4' & -- '4' 52
'5' & -- '5' 53
'6' & -- '6' 54
'7' & -- '7' 55
'8' & -- '8' 56
'9' & -- '9' 57
L.Colon & -- ':' 58
L.Semicolon & -- ';' 59
L.Less_Than_Sign & -- '<' 60
L.Equals_Sign & -- '=' 61
L.Greater_Than_Sign & -- '>' 62
L.Question & -- '?' 63
L.Commercial_At & -- '@' 64
L.LC_A & -- 'a' 65
L.LC_B & -- 'b' 66
L.LC_C & -- 'c' 67
L.LC_D & -- 'd' 68
L.LC_E & -- 'e' 69
L.LC_F & -- 'f' 70
L.LC_G & -- 'g' 71
L.LC_H & -- 'h' 72
L.LC_I & -- 'i' 73
L.LC_J & -- 'j' 74
L.LC_K & -- 'k' 75
L.LC_L & -- 'l' 76
L.LC_M & -- 'm' 77
L.LC_N & -- 'n' 78
L.LC_O & -- 'o' 79
L.LC_P & -- 'p' 80
L.LC_Q & -- 'q' 81
L.LC_R & -- 'r' 82
L.LC_S & -- 's' 83
L.LC_T & -- 't' 84
L.LC_U & -- 'u' 85
L.LC_V & -- 'v' 86
L.LC_W & -- 'w' 87
L.LC_X & -- 'x' 88
L.LC_Y & -- 'y' 89
L.LC_Z & -- 'z' 90
L.Left_Square_Bracket & -- '[' 91
L.Reverse_Solidus & -- '\' 92
L.Right_Square_Bracket & -- ']' 93
L.Circumflex & -- '^' 94
L.Low_Line & -- '_' 95
L.Grave & -- '`' 96
L.LC_A & -- 'a' 97
L.LC_B & -- 'b' 98
L.LC_C & -- 'c' 99
L.LC_D & -- 'd' 100
L.LC_E & -- 'e' 101
L.LC_F & -- 'f' 102
L.LC_G & -- 'g' 103
L.LC_H & -- 'h' 104
L.LC_I & -- 'i' 105
L.LC_J & -- 'j' 106
L.LC_K & -- 'k' 107
L.LC_L & -- 'l' 108
L.LC_M & -- 'm' 109
L.LC_N & -- 'n' 110
L.LC_O & -- 'o' 111
L.LC_P & -- 'p' 112
L.LC_Q & -- 'q' 113
L.LC_R & -- 'r' 114
L.LC_S & -- 's' 115
L.LC_T & -- 't' 116
L.LC_U & -- 'u' 117
L.LC_V & -- 'v' 118
L.LC_W & -- 'w' 119
L.LC_X & -- 'x' 120
L.LC_Y & -- 'y' 121
L.LC_Z & -- 'z' 122
L.Left_Curly_Bracket & -- '{' 123
L.Vertical_Line & -- '|' 124
L.Right_Curly_Bracket & -- '}' 125
L.Tilde & -- '~' 126
L.DEL & -- DEL 127
L.Reserved_128 & -- Reserved_128 128
L.Reserved_129 & -- Reserved_129 129
L.BPH & -- BPH 130
L.NBH & -- NBH 131
L.Reserved_132 & -- Reserved_132 132
L.NEL & -- NEL 133
L.SSA & -- SSA 134
L.ESA & -- ESA 135
L.HTS & -- HTS 136
L.HTJ & -- HTJ 137
L.VTS & -- VTS 138
L.PLD & -- PLD 139
L.PLU & -- PLU 140
L.RI & -- RI 141
L.SS2 & -- SS2 142
L.SS3 & -- SS3 143
L.DCS & -- DCS 144
L.PU1 & -- PU1 145
L.PU2 & -- PU2 146
L.STS & -- STS 147
L.CCH & -- CCH 148
L.MW & -- MW 149
L.SPA & -- SPA 150
L.EPA & -- EPA 151
L.SOS & -- SOS 152
L.Reserved_153 & -- Reserved_153 153
L.SCI & -- SCI 154
L.CSI & -- CSI 155
L.ST & -- ST 156
L.OSC & -- OSC 157
L.PM & -- PM 158
L.APC & -- APC 159
L.No_Break_Space & -- No_Break_Space 160
L.Inverted_Exclamation & -- Inverted_Exclamation 161
L.Cent_Sign & -- Cent_Sign 162
L.Pound_Sign & -- Pound_Sign 163
L.Currency_Sign & -- Currency_Sign 164
L.Yen_Sign & -- Yen_Sign 165
L.Broken_Bar & -- Broken_Bar 166
L.Section_Sign & -- Section_Sign 167
L.Diaeresis & -- Diaeresis 168
L.Copyright_Sign & -- Copyright_Sign 169
L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170
L.Left_Angle_Quotation & -- Left_Angle_Quotation 171
L.Not_Sign & -- Not_Sign 172
L.Soft_Hyphen & -- Soft_Hyphen 173
L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174
L.Macron & -- Macron 175
L.Degree_Sign & -- Degree_Sign 176
L.Plus_Minus_Sign & -- Plus_Minus_Sign 177
L.Superscript_Two & -- Superscript_Two 178
L.Superscript_Three & -- Superscript_Three 179
L.Acute & -- Acute 180
L.Micro_Sign & -- Micro_Sign 181
L.Pilcrow_Sign & -- Pilcrow_Sign 182
L.Middle_Dot & -- Middle_Dot 183
L.Cedilla & -- Cedilla 184
L.Superscript_One & -- Superscript_One 185
L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186
L.Right_Angle_Quotation & -- Right_Angle_Quotation 187
L.Fraction_One_Quarter & -- Fraction_One_Quarter 188
L.Fraction_One_Half & -- Fraction_One_Half 189
L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190
L.Inverted_Question & -- Inverted_Question 191
L.LC_A_Grave & -- UC_A_Grave 192
L.LC_A_Acute & -- UC_A_Acute 193
L.LC_A_Circumflex & -- UC_A_Circumflex 194
L.LC_A_Tilde & -- UC_A_Tilde 195
L.LC_A_Diaeresis & -- UC_A_Diaeresis 196
L.LC_A_Ring & -- UC_A_Ring 197
L.LC_AE_Diphthong & -- UC_AE_Diphthong 198
L.LC_C_Cedilla & -- UC_C_Cedilla 199
L.LC_E_Grave & -- UC_E_Grave 200
L.LC_E_Acute & -- UC_E_Acute 201
L.LC_E_Circumflex & -- UC_E_Circumflex 202
L.LC_E_Diaeresis & -- UC_E_Diaeresis 203
L.LC_I_Grave & -- UC_I_Grave 204
L.LC_I_Acute & -- UC_I_Acute 205
L.LC_I_Circumflex & -- UC_I_Circumflex 206
L.LC_I_Diaeresis & -- UC_I_Diaeresis 207
L.LC_Icelandic_Eth & -- UC_Icelandic_Eth 208
L.LC_N_Tilde & -- UC_N_Tilde 209
L.LC_O_Grave & -- UC_O_Grave 210
L.LC_O_Acute & -- UC_O_Acute 211
L.LC_O_Circumflex & -- UC_O_Circumflex 212
L.LC_O_Tilde & -- UC_O_Tilde 213
L.LC_O_Diaeresis & -- UC_O_Diaeresis 214
L.Multiplication_Sign & -- Multiplication_Sign 215
L.LC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216
L.LC_U_Grave & -- UC_U_Grave 217
L.LC_U_Acute & -- UC_U_Acute 218
L.LC_U_Circumflex & -- UC_U_Circumflex 219
L.LC_U_Diaeresis & -- UC_U_Diaeresis 220
L.LC_Y_Acute & -- UC_Y_Acute 221
L.LC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222
L.LC_German_Sharp_S & -- LC_German_Sharp_S 223
L.LC_A_Grave & -- LC_A_Grave 224
L.LC_A_Acute & -- LC_A_Acute 225
L.LC_A_Circumflex & -- LC_A_Circumflex 226
L.LC_A_Tilde & -- LC_A_Tilde 227
L.LC_A_Diaeresis & -- LC_A_Diaeresis 228
L.LC_A_Ring & -- LC_A_Ring 229
L.LC_AE_Diphthong & -- LC_AE_Diphthong 230
L.LC_C_Cedilla & -- LC_C_Cedilla 231
L.LC_E_Grave & -- LC_E_Grave 232
L.LC_E_Acute & -- LC_E_Acute 233
L.LC_E_Circumflex & -- LC_E_Circumflex 234
L.LC_E_Diaeresis & -- LC_E_Diaeresis 235
L.LC_I_Grave & -- LC_I_Grave 236
L.LC_I_Acute & -- LC_I_Acute 237
L.LC_I_Circumflex & -- LC_I_Circumflex 238
L.LC_I_Diaeresis & -- LC_I_Diaeresis 239
L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240
L.LC_N_Tilde & -- LC_N_Tilde 241
L.LC_O_Grave & -- LC_O_Grave 242
L.LC_O_Acute & -- LC_O_Acute 243
L.LC_O_Circumflex & -- LC_O_Circumflex 244
L.LC_O_Tilde & -- LC_O_Tilde 245
L.LC_O_Diaeresis & -- LC_O_Diaeresis 246
L.Division_Sign & -- Division_Sign 247
L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248
L.LC_U_Grave & -- LC_U_Grave 249
L.LC_U_Acute & -- LC_U_Acute 250
L.LC_U_Circumflex & -- LC_U_Circumflex 251
L.LC_U_Diaeresis & -- LC_U_Diaeresis 252
L.LC_Y_Acute & -- LC_Y_Acute 253
L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254
L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255
Upper_Case_Map : constant Character_Mapping :=
(L.NUL & -- NUL 0
L.SOH & -- SOH 1
L.STX & -- STX 2
L.ETX & -- ETX 3
L.EOT & -- EOT 4
L.ENQ & -- ENQ 5
L.ACK & -- ACK 6
L.BEL & -- BEL 7
L.BS & -- BS 8
L.HT & -- HT 9
L.LF & -- LF 10
L.VT & -- VT 11
L.FF & -- FF 12
L.CR & -- CR 13
L.SO & -- SO 14
L.SI & -- SI 15
L.DLE & -- DLE 16
L.DC1 & -- DC1 17
L.DC2 & -- DC2 18
L.DC3 & -- DC3 19
L.DC4 & -- DC4 20
L.NAK & -- NAK 21
L.SYN & -- SYN 22
L.ETB & -- ETB 23
L.CAN & -- CAN 24
L.EM & -- EM 25
L.SUB & -- SUB 26
L.ESC & -- ESC 27
L.FS & -- FS 28
L.GS & -- GS 29
L.RS & -- RS 30
L.US & -- US 31
L.Space & -- ' ' 32
L.Exclamation & -- '!' 33
L.Quotation & -- '"' 34
L.Number_Sign & -- '#' 35
L.Dollar_Sign & -- '$' 36
L.Percent_Sign & -- '%' 37
L.Ampersand & -- '&' 38
L.Apostrophe & -- ''' 39
L.Left_Parenthesis & -- '(' 40
L.Right_Parenthesis & -- ')' 41
L.Asterisk & -- '*' 42
L.Plus_Sign & -- '+' 43
L.Comma & -- ',' 44
L.Hyphen & -- '-' 45
L.Full_Stop & -- '.' 46
L.Solidus & -- '/' 47
'0' & -- '0' 48
'1' & -- '1' 49
'2' & -- '2' 50
'3' & -- '3' 51
'4' & -- '4' 52
'5' & -- '5' 53
'6' & -- '6' 54
'7' & -- '7' 55
'8' & -- '8' 56
'9' & -- '9' 57
L.Colon & -- ':' 58
L.Semicolon & -- ';' 59
L.Less_Than_Sign & -- '<' 60
L.Equals_Sign & -- '=' 61
L.Greater_Than_Sign & -- '>' 62
L.Question & -- '?' 63
L.Commercial_At & -- '@' 64
'A' & -- 'A' 65
'B' & -- 'B' 66
'C' & -- 'C' 67
'D' & -- 'D' 68
'E' & -- 'E' 69
'F' & -- 'F' 70
'G' & -- 'G' 71
'H' & -- 'H' 72
'I' & -- 'I' 73
'J' & -- 'J' 74
'K' & -- 'K' 75
'L' & -- 'L' 76
'M' & -- 'M' 77
'N' & -- 'N' 78
'O' & -- 'O' 79
'P' & -- 'P' 80
'Q' & -- 'Q' 81
'R' & -- 'R' 82
'S' & -- 'S' 83
'T' & -- 'T' 84
'U' & -- 'U' 85
'V' & -- 'V' 86
'W' & -- 'W' 87
'X' & -- 'X' 88
'Y' & -- 'Y' 89
'Z' & -- 'Z' 90
L.Left_Square_Bracket & -- '[' 91
L.Reverse_Solidus & -- '\' 92
L.Right_Square_Bracket & -- ']' 93
L.Circumflex & -- '^' 94
L.Low_Line & -- '_' 95
L.Grave & -- '`' 96
'A' & -- 'a' 97
'B' & -- 'b' 98
'C' & -- 'c' 99
'D' & -- 'd' 100
'E' & -- 'e' 101
'F' & -- 'f' 102
'G' & -- 'g' 103
'H' & -- 'h' 104
'I' & -- 'i' 105
'J' & -- 'j' 106
'K' & -- 'k' 107
'L' & -- 'l' 108
'M' & -- 'm' 109
'N' & -- 'n' 110
'O' & -- 'o' 111
'P' & -- 'p' 112
'Q' & -- 'q' 113
'R' & -- 'r' 114
'S' & -- 's' 115
'T' & -- 't' 116
'U' & -- 'u' 117
'V' & -- 'v' 118
'W' & -- 'w' 119
'X' & -- 'x' 120
'Y' & -- 'y' 121
'Z' & -- 'z' 122
L.Left_Curly_Bracket & -- '{' 123
L.Vertical_Line & -- '|' 124
L.Right_Curly_Bracket & -- '}' 125
L.Tilde & -- '~' 126
L.DEL & -- DEL 127
L.Reserved_128 & -- Reserved_128 128
L.Reserved_129 & -- Reserved_129 129
L.BPH & -- BPH 130
L.NBH & -- NBH 131
L.Reserved_132 & -- Reserved_132 132
L.NEL & -- NEL 133
L.SSA & -- SSA 134
L.ESA & -- ESA 135
L.HTS & -- HTS 136
L.HTJ & -- HTJ 137
L.VTS & -- VTS 138
L.PLD & -- PLD 139
L.PLU & -- PLU 140
L.RI & -- RI 141
L.SS2 & -- SS2 142
L.SS3 & -- SS3 143
L.DCS & -- DCS 144
L.PU1 & -- PU1 145
L.PU2 & -- PU2 146
L.STS & -- STS 147
L.CCH & -- CCH 148
L.MW & -- MW 149
L.SPA & -- SPA 150
L.EPA & -- EPA 151
L.SOS & -- SOS 152
L.Reserved_153 & -- Reserved_153 153
L.SCI & -- SCI 154
L.CSI & -- CSI 155
L.ST & -- ST 156
L.OSC & -- OSC 157
L.PM & -- PM 158
L.APC & -- APC 159
L.No_Break_Space & -- No_Break_Space 160
L.Inverted_Exclamation & -- Inverted_Exclamation 161
L.Cent_Sign & -- Cent_Sign 162
L.Pound_Sign & -- Pound_Sign 163
L.Currency_Sign & -- Currency_Sign 164
L.Yen_Sign & -- Yen_Sign 165
L.Broken_Bar & -- Broken_Bar 166
L.Section_Sign & -- Section_Sign 167
L.Diaeresis & -- Diaeresis 168
L.Copyright_Sign & -- Copyright_Sign 169
L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170
L.Left_Angle_Quotation & -- Left_Angle_Quotation 171
L.Not_Sign & -- Not_Sign 172
L.Soft_Hyphen & -- Soft_Hyphen 173
L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174
L.Macron & -- Macron 175
L.Degree_Sign & -- Degree_Sign 176
L.Plus_Minus_Sign & -- Plus_Minus_Sign 177
L.Superscript_Two & -- Superscript_Two 178
L.Superscript_Three & -- Superscript_Three 179
L.Acute & -- Acute 180
L.Micro_Sign & -- Micro_Sign 181
L.Pilcrow_Sign & -- Pilcrow_Sign 182
L.Middle_Dot & -- Middle_Dot 183
L.Cedilla & -- Cedilla 184
L.Superscript_One & -- Superscript_One 185
L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186
L.Right_Angle_Quotation & -- Right_Angle_Quotation 187
L.Fraction_One_Quarter & -- Fraction_One_Quarter 188
L.Fraction_One_Half & -- Fraction_One_Half 189
L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190
L.Inverted_Question & -- Inverted_Question 191
L.UC_A_Grave & -- UC_A_Grave 192
L.UC_A_Acute & -- UC_A_Acute 193
L.UC_A_Circumflex & -- UC_A_Circumflex 194
L.UC_A_Tilde & -- UC_A_Tilde 195
L.UC_A_Diaeresis & -- UC_A_Diaeresis 196
L.UC_A_Ring & -- UC_A_Ring 197
L.UC_AE_Diphthong & -- UC_AE_Diphthong 198
L.UC_C_Cedilla & -- UC_C_Cedilla 199
L.UC_E_Grave & -- UC_E_Grave 200
L.UC_E_Acute & -- UC_E_Acute 201
L.UC_E_Circumflex & -- UC_E_Circumflex 202
L.UC_E_Diaeresis & -- UC_E_Diaeresis 203
L.UC_I_Grave & -- UC_I_Grave 204
L.UC_I_Acute & -- UC_I_Acute 205
L.UC_I_Circumflex & -- UC_I_Circumflex 206
L.UC_I_Diaeresis & -- UC_I_Diaeresis 207
L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208
L.UC_N_Tilde & -- UC_N_Tilde 209
L.UC_O_Grave & -- UC_O_Grave 210
L.UC_O_Acute & -- UC_O_Acute 211
L.UC_O_Circumflex & -- UC_O_Circumflex 212
L.UC_O_Tilde & -- UC_O_Tilde 213
L.UC_O_Diaeresis & -- UC_O_Diaeresis 214
L.Multiplication_Sign & -- Multiplication_Sign 215
L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216
L.UC_U_Grave & -- UC_U_Grave 217
L.UC_U_Acute & -- UC_U_Acute 218
L.UC_U_Circumflex & -- UC_U_Circumflex 219
L.UC_U_Diaeresis & -- UC_U_Diaeresis 220
L.UC_Y_Acute & -- UC_Y_Acute 221
L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222
L.LC_German_Sharp_S & -- LC_German_Sharp_S 223
L.UC_A_Grave & -- LC_A_Grave 224
L.UC_A_Acute & -- LC_A_Acute 225
L.UC_A_Circumflex & -- LC_A_Circumflex 226
L.UC_A_Tilde & -- LC_A_Tilde 227
L.UC_A_Diaeresis & -- LC_A_Diaeresis 228
L.UC_A_Ring & -- LC_A_Ring 229
L.UC_AE_Diphthong & -- LC_AE_Diphthong 230
L.UC_C_Cedilla & -- LC_C_Cedilla 231
L.UC_E_Grave & -- LC_E_Grave 232
L.UC_E_Acute & -- LC_E_Acute 233
L.UC_E_Circumflex & -- LC_E_Circumflex 234
L.UC_E_Diaeresis & -- LC_E_Diaeresis 235
L.UC_I_Grave & -- LC_I_Grave 236
L.UC_I_Acute & -- LC_I_Acute 237
L.UC_I_Circumflex & -- LC_I_Circumflex 238
L.UC_I_Diaeresis & -- LC_I_Diaeresis 239
L.UC_Icelandic_Eth & -- LC_Icelandic_Eth 240
L.UC_N_Tilde & -- LC_N_Tilde 241
L.UC_O_Grave & -- LC_O_Grave 242
L.UC_O_Acute & -- LC_O_Acute 243
L.UC_O_Circumflex & -- LC_O_Circumflex 244
L.UC_O_Tilde & -- LC_O_Tilde 245
L.UC_O_Diaeresis & -- LC_O_Diaeresis 246
L.Division_Sign & -- Division_Sign 247
L.UC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248
L.UC_U_Grave & -- LC_U_Grave 249
L.UC_U_Acute & -- LC_U_Acute 250
L.UC_U_Circumflex & -- LC_U_Circumflex 251
L.UC_U_Diaeresis & -- LC_U_Diaeresis 252
L.UC_Y_Acute & -- LC_Y_Acute 253
L.UC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254
L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255
Basic_Map : constant Character_Mapping :=
(L.NUL & -- NUL 0
L.SOH & -- SOH 1
L.STX & -- STX 2
L.ETX & -- ETX 3
L.EOT & -- EOT 4
L.ENQ & -- ENQ 5
L.ACK & -- ACK 6
L.BEL & -- BEL 7
L.BS & -- BS 8
L.HT & -- HT 9
L.LF & -- LF 10
L.VT & -- VT 11
L.FF & -- FF 12
L.CR & -- CR 13
L.SO & -- SO 14
L.SI & -- SI 15
L.DLE & -- DLE 16
L.DC1 & -- DC1 17
L.DC2 & -- DC2 18
L.DC3 & -- DC3 19
L.DC4 & -- DC4 20
L.NAK & -- NAK 21
L.SYN & -- SYN 22
L.ETB & -- ETB 23
L.CAN & -- CAN 24
L.EM & -- EM 25
L.SUB & -- SUB 26
L.ESC & -- ESC 27
L.FS & -- FS 28
L.GS & -- GS 29
L.RS & -- RS 30
L.US & -- US 31
L.Space & -- ' ' 32
L.Exclamation & -- '!' 33
L.Quotation & -- '"' 34
L.Number_Sign & -- '#' 35
L.Dollar_Sign & -- '$' 36
L.Percent_Sign & -- '%' 37
L.Ampersand & -- '&' 38
L.Apostrophe & -- ''' 39
L.Left_Parenthesis & -- '(' 40
L.Right_Parenthesis & -- ')' 41
L.Asterisk & -- '*' 42
L.Plus_Sign & -- '+' 43
L.Comma & -- ',' 44
L.Hyphen & -- '-' 45
L.Full_Stop & -- '.' 46
L.Solidus & -- '/' 47
'0' & -- '0' 48
'1' & -- '1' 49
'2' & -- '2' 50
'3' & -- '3' 51
'4' & -- '4' 52
'5' & -- '5' 53
'6' & -- '6' 54
'7' & -- '7' 55
'8' & -- '8' 56
'9' & -- '9' 57
L.Colon & -- ':' 58
L.Semicolon & -- ';' 59
L.Less_Than_Sign & -- '<' 60
L.Equals_Sign & -- '=' 61
L.Greater_Than_Sign & -- '>' 62
L.Question & -- '?' 63
L.Commercial_At & -- '@' 64
'A' & -- 'A' 65
'B' & -- 'B' 66
'C' & -- 'C' 67
'D' & -- 'D' 68
'E' & -- 'E' 69
'F' & -- 'F' 70
'G' & -- 'G' 71
'H' & -- 'H' 72
'I' & -- 'I' 73
'J' & -- 'J' 74
'K' & -- 'K' 75
'L' & -- 'L' 76
'M' & -- 'M' 77
'N' & -- 'N' 78
'O' & -- 'O' 79
'P' & -- 'P' 80
'Q' & -- 'Q' 81
'R' & -- 'R' 82
'S' & -- 'S' 83
'T' & -- 'T' 84
'U' & -- 'U' 85
'V' & -- 'V' 86
'W' & -- 'W' 87
'X' & -- 'X' 88
'Y' & -- 'Y' 89
'Z' & -- 'Z' 90
L.Left_Square_Bracket & -- '[' 91
L.Reverse_Solidus & -- '\' 92
L.Right_Square_Bracket & -- ']' 93
L.Circumflex & -- '^' 94
L.Low_Line & -- '_' 95
L.Grave & -- '`' 96
L.LC_A & -- 'a' 97
L.LC_B & -- 'b' 98
L.LC_C & -- 'c' 99
L.LC_D & -- 'd' 100
L.LC_E & -- 'e' 101
L.LC_F & -- 'f' 102
L.LC_G & -- 'g' 103
L.LC_H & -- 'h' 104
L.LC_I & -- 'i' 105
L.LC_J & -- 'j' 106
L.LC_K & -- 'k' 107
L.LC_L & -- 'l' 108
L.LC_M & -- 'm' 109
L.LC_N & -- 'n' 110
L.LC_O & -- 'o' 111
L.LC_P & -- 'p' 112
L.LC_Q & -- 'q' 113
L.LC_R & -- 'r' 114
L.LC_S & -- 's' 115
L.LC_T & -- 't' 116
L.LC_U & -- 'u' 117
L.LC_V & -- 'v' 118
L.LC_W & -- 'w' 119
L.LC_X & -- 'x' 120
L.LC_Y & -- 'y' 121
L.LC_Z & -- 'z' 122
L.Left_Curly_Bracket & -- '{' 123
L.Vertical_Line & -- '|' 124
L.Right_Curly_Bracket & -- '}' 125
L.Tilde & -- '~' 126
L.DEL & -- DEL 127
L.Reserved_128 & -- Reserved_128 128
L.Reserved_129 & -- Reserved_129 129
L.BPH & -- BPH 130
L.NBH & -- NBH 131
L.Reserved_132 & -- Reserved_132 132
L.NEL & -- NEL 133
L.SSA & -- SSA 134
L.ESA & -- ESA 135
L.HTS & -- HTS 136
L.HTJ & -- HTJ 137
L.VTS & -- VTS 138
L.PLD & -- PLD 139
L.PLU & -- PLU 140
L.RI & -- RI 141
L.SS2 & -- SS2 142
L.SS3 & -- SS3 143
L.DCS & -- DCS 144
L.PU1 & -- PU1 145
L.PU2 & -- PU2 146
L.STS & -- STS 147
L.CCH & -- CCH 148
L.MW & -- MW 149
L.SPA & -- SPA 150
L.EPA & -- EPA 151
L.SOS & -- SOS 152
L.Reserved_153 & -- Reserved_153 153
L.SCI & -- SCI 154
L.CSI & -- CSI 155
L.ST & -- ST 156
L.OSC & -- OSC 157
L.PM & -- PM 158
L.APC & -- APC 159
L.No_Break_Space & -- No_Break_Space 160
L.Inverted_Exclamation & -- Inverted_Exclamation 161
L.Cent_Sign & -- Cent_Sign 162
L.Pound_Sign & -- Pound_Sign 163
L.Currency_Sign & -- Currency_Sign 164
L.Yen_Sign & -- Yen_Sign 165
L.Broken_Bar & -- Broken_Bar 166
L.Section_Sign & -- Section_Sign 167
L.Diaeresis & -- Diaeresis 168
L.Copyright_Sign & -- Copyright_Sign 169
L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170
L.Left_Angle_Quotation & -- Left_Angle_Quotation 171
L.Not_Sign & -- Not_Sign 172
L.Soft_Hyphen & -- Soft_Hyphen 173
L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174
L.Macron & -- Macron 175
L.Degree_Sign & -- Degree_Sign 176
L.Plus_Minus_Sign & -- Plus_Minus_Sign 177
L.Superscript_Two & -- Superscript_Two 178
L.Superscript_Three & -- Superscript_Three 179
L.Acute & -- Acute 180
L.Micro_Sign & -- Micro_Sign 181
L.Pilcrow_Sign & -- Pilcrow_Sign 182
L.Middle_Dot & -- Middle_Dot 183
L.Cedilla & -- Cedilla 184
L.Superscript_One & -- Superscript_One 185
L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186
L.Right_Angle_Quotation & -- Right_Angle_Quotation 187
L.Fraction_One_Quarter & -- Fraction_One_Quarter 188
L.Fraction_One_Half & -- Fraction_One_Half 189
L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190
L.Inverted_Question & -- Inverted_Question 191
'A' & -- UC_A_Grave 192
'A' & -- UC_A_Acute 193
'A' & -- UC_A_Circumflex 194
'A' & -- UC_A_Tilde 195
'A' & -- UC_A_Diaeresis 196
'A' & -- UC_A_Ring 197
L.UC_AE_Diphthong & -- UC_AE_Diphthong 198
'C' & -- UC_C_Cedilla 199
'E' & -- UC_E_Grave 200
'E' & -- UC_E_Acute 201
'E' & -- UC_E_Circumflex 202
'E' & -- UC_E_Diaeresis 203
'I' & -- UC_I_Grave 204
'I' & -- UC_I_Acute 205
'I' & -- UC_I_Circumflex 206
'I' & -- UC_I_Diaeresis 207
L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208
'N' & -- UC_N_Tilde 209
'O' & -- UC_O_Grave 210
'O' & -- UC_O_Acute 211
'O' & -- UC_O_Circumflex 212
'O' & -- UC_O_Tilde 213
'O' & -- UC_O_Diaeresis 214
L.Multiplication_Sign & -- Multiplication_Sign 215
'O' & -- UC_O_Oblique_Stroke 216
'U' & -- UC_U_Grave 217
'U' & -- UC_U_Acute 218
'U' & -- UC_U_Circumflex 219
'U' & -- UC_U_Diaeresis 220
'Y' & -- UC_Y_Acute 221
L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222
L.LC_German_Sharp_S & -- LC_German_Sharp_S 223
L.LC_A & -- LC_A_Grave 224
L.LC_A & -- LC_A_Acute 225
L.LC_A & -- LC_A_Circumflex 226
L.LC_A & -- LC_A_Tilde 227
L.LC_A & -- LC_A_Diaeresis 228
L.LC_A & -- LC_A_Ring 229
L.LC_AE_Diphthong & -- LC_AE_Diphthong 230
L.LC_C & -- LC_C_Cedilla 231
L.LC_E & -- LC_E_Grave 232
L.LC_E & -- LC_E_Acute 233
L.LC_E & -- LC_E_Circumflex 234
L.LC_E & -- LC_E_Diaeresis 235
L.LC_I & -- LC_I_Grave 236
L.LC_I & -- LC_I_Acute 237
L.LC_I & -- LC_I_Circumflex 238
L.LC_I & -- LC_I_Diaeresis 239
L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240
L.LC_N & -- LC_N_Tilde 241
L.LC_O & -- LC_O_Grave 242
L.LC_O & -- LC_O_Acute 243
L.LC_O & -- LC_O_Circumflex 244
L.LC_O & -- LC_O_Tilde 245
L.LC_O & -- LC_O_Diaeresis 246
L.Division_Sign & -- Division_Sign 247
L.LC_O & -- LC_O_Oblique_Stroke 248
L.LC_U & -- LC_U_Grave 249
L.LC_U & -- LC_U_Acute 250
L.LC_U & -- LC_U_Circumflex 251
L.LC_U & -- LC_U_Diaeresis 252
L.LC_Y & -- LC_Y_Acute 253
L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254
L.LC_Y); -- LC_Y_Diaeresis 255
end Ada.Strings.Maps.Constants;

64
gcc/ada/a-storio.adb Normal file
View File

@ -0,0 +1,64 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T O R A G E _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- 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. --
-- --
-- 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.Address_To_Access_Conversions;
package body Ada.Storage_IO is
package Element_Ops is new
System.Address_To_Access_Conversions (Element_Type);
----------
-- Read --
----------
procedure Read (Buffer : in Buffer_Type; Item : out Element_Type) is
begin
Element_Ops.To_Pointer (Item'Address).all :=
Element_Ops.To_Pointer (Buffer'Address).all;
end Read;
-----------
-- Write --
-----------
procedure Write (Buffer : out Buffer_Type; Item : in Element_Type) is
begin
Element_Ops.To_Pointer (Buffer'Address).all :=
Element_Ops.To_Pointer (Item'Address).all;
end Write;
end Ada.Storage_IO;

49
gcc/ada/a-storio.ads Normal file
View File

@ -0,0 +1,49 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T O R A G E _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
with Ada.IO_Exceptions;
with System.Storage_Elements;
generic
type Element_Type is private;
package Ada.Storage_IO is
pragma Preelaborate (Storage_IO);
Buffer_Size : constant System.Storage_Elements.Storage_Count :=
System.Storage_Elements.Storage_Count
((Element_Type'Size + System.Storage_Unit - 1) /
System.Storage_Unit);
subtype Buffer_Type is
System.Storage_Elements.Storage_Array (1 .. Buffer_Size);
---------------------------------
-- Input and Output Operations --
---------------------------------
procedure Read (Buffer : in Buffer_Type; Item : out Element_Type);
procedure Write (Buffer : out Buffer_Type; Item : in Element_Type);
----------------
-- Exceptions --
----------------
Data_Error : exception renames IO_Exceptions.Data_Error;
end Ada.Storage_IO;

1777
gcc/ada/a-strbou.adb Normal file
View File

File diff suppressed because it is too large Load Diff

467
gcc/ada/a-strbou.ads Normal file
View File

@ -0,0 +1,467 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R I N G S . B O U N D E D --
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, 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.Strings.Maps;
package Ada.Strings.Bounded is
pragma Preelaborate (Bounded);
generic
Max : Positive;
-- Maximum length of a Bounded_String
package Generic_Bounded_Length is
Max_Length : constant Positive := Max;
type Bounded_String is private;
Null_Bounded_String : constant Bounded_String;
subtype Length_Range is Natural range 0 .. Max_Length;
function Length (Source : in Bounded_String) return Length_Range;
--------------------------------------------------------
-- Conversion, Concatenation, and Selection Functions --
--------------------------------------------------------
function To_Bounded_String
(Source : in String;
Drop : in Truncation := Error)
return Bounded_String;
function To_String (Source : in Bounded_String) return String;
function Append
(Left, Right : in Bounded_String;
Drop : in Truncation := Error)
return Bounded_String;
function Append
(Left : in Bounded_String;
Right : in String;
Drop : in Truncation := Error)
return Bounded_String;
function Append
(Left : in String;
Right : in Bounded_String;
Drop : in Truncation := Error)
return Bounded_String;
function Append
(Left : in Bounded_String;
Right : in Character;
Drop : in Truncation := Error)
return Bounded_String;
function Append
(Left : in Character;
Right : in Bounded_String;
Drop : in Truncation := Error)
return Bounded_String;
procedure Append
(Source : in out Bounded_String;
New_Item : in Bounded_String;
Drop : in Truncation := Error);
procedure Append
(Source : in out Bounded_String;
New_Item : in String;
Drop : in Truncation := Error);
procedure Append
(Source : in out Bounded_String;
New_Item : in Character;
Drop : in Truncation := Error);
function "&"
(Left, Right : in Bounded_String)
return Bounded_String;
function "&"
(Left : in Bounded_String;
Right : in String)
return Bounded_String;
function "&"
(Left : in String;
Right : in Bounded_String)
return Bounded_String;
function "&"
(Left : in Bounded_String;
Right : in Character)
return Bounded_String;
function "&"
(Left : in Character;
Right : in Bounded_String)
return Bounded_String;
function Element
(Source : in Bounded_String;
Index : in Positive)
return Character;
procedure Replace_Element
(Source : in out Bounded_String;
Index : in Positive;
By : in Character);
function Slice
(Source : in Bounded_String;
Low : in Positive;
High : in Natural)
return String;
function "=" (Left, Right : in Bounded_String) return Boolean;
function "="
(Left : in Bounded_String;
Right : in String)
return Boolean;
function "="
(Left : in String;
Right : in Bounded_String)
return Boolean;
function "<" (Left, Right : in Bounded_String) return Boolean;
function "<"
(Left : in Bounded_String;
Right : in String)
return Boolean;
function "<"
(Left : in String;
Right : in Bounded_String)
return Boolean;
function "<=" (Left, Right : in Bounded_String) return Boolean;
function "<="
(Left : in Bounded_String;
Right : in String)
return Boolean;
function "<="
(Left : in String;
Right : in Bounded_String)
return Boolean;
function ">" (Left, Right : in Bounded_String) return Boolean;
function ">"
(Left : in Bounded_String;
Right : in String)
return Boolean;
function ">"
(Left : in String;
Right : in Bounded_String)
return Boolean;
function ">=" (Left, Right : in Bounded_String) return Boolean;
function ">="
(Left : in Bounded_String;
Right : in String)
return Boolean;
function ">="
(Left : in String;
Right : in Bounded_String)
return Boolean;
----------------------
-- Search Functions --
----------------------
function Index
(Source : in Bounded_String;
Pattern : in String;
Going : in Direction := Forward;
Mapping : in Maps.Character_Mapping := Maps.Identity)
return Natural;
function Index
(Source : in Bounded_String;
Pattern : in String;
Going : in Direction := Forward;
Mapping : in Maps.Character_Mapping_Function)
return Natural;
function Index
(Source : in Bounded_String;
Set : in Maps.Character_Set;
Test : in Membership := Inside;
Going : in Direction := Forward)
return Natural;
function Index_Non_Blank
(Source : in Bounded_String;
Going : in Direction := Forward)
return Natural;
function Count
(Source : in Bounded_String;
Pattern : in String;
Mapping : in Maps.Character_Mapping := Maps.Identity)
return Natural;
function Count
(Source : in Bounded_String;
Pattern : in String;
Mapping : in Maps.Character_Mapping_Function)
return Natural;
function Count
(Source : in Bounded_String;
Set : in Maps.Character_Set)
return Natural;
procedure Find_Token
(Source : in Bounded_String;
Set : in Maps.Character_Set;
Test : in Membership;
First : out Positive;
Last : out Natural);
------------------------------------
-- String Translation Subprograms --
------------------------------------
function Translate
(Source : in Bounded_String;
Mapping : in Maps.Character_Mapping)
return Bounded_String;
procedure Translate
(Source : in out Bounded_String;
Mapping : in Maps.Character_Mapping);
function Translate
(Source : in Bounded_String;
Mapping : in Maps.Character_Mapping_Function)
return Bounded_String;
procedure Translate
(Source : in out Bounded_String;
Mapping : in Maps.Character_Mapping_Function);
---------------------------------------
-- String Transformation Subprograms --
---------------------------------------
function Replace_Slice
(Source : in Bounded_String;
Low : in Positive;
High : in Natural;
By : in String;
Drop : in Truncation := Error)
return Bounded_String;
procedure Replace_Slice
(Source : in out Bounded_String;
Low : in Positive;
High : in Natural;
By : in String;
Drop : in Truncation := Error);
function Insert
(Source : in Bounded_String;
Before : in Positive;
New_Item : in String;
Drop : in Truncation := Error)
return Bounded_String;
procedure Insert
(Source : in out Bounded_String;
Before : in Positive;
New_Item : in String;
Drop : in Truncation := Error);
function Overwrite
(Source : in Bounded_String;
Position : in Positive;
New_Item : in String;
Drop : in Truncation := Error)
return Bounded_String;
procedure Overwrite
(Source : in out Bounded_String;
Position : in Positive;
New_Item : in String;
Drop : in Truncation := Error);
function Delete
(Source : in Bounded_String;
From : in Positive;
Through : in Natural)
return Bounded_String;
procedure Delete
(Source : in out Bounded_String;
From : in Positive;
Through : in Natural);
---------------------------------
-- String Selector Subprograms --
---------------------------------
function Trim
(Source : in Bounded_String;
Side : in Trim_End)
return Bounded_String;
procedure Trim
(Source : in out Bounded_String;
Side : in Trim_End);
function Trim
(Source : in Bounded_String;
Left : in Maps.Character_Set;
Right : in Maps.Character_Set)
return Bounded_String;
procedure Trim
(Source : in out Bounded_String;
Left : in Maps.Character_Set;
Right : in Maps.Character_Set);
function Head
(Source : in Bounded_String;
Count : in Natural;
Pad : in Character := Space;
Drop : in Truncation := Error)
return Bounded_String;
procedure Head
(Source : in out Bounded_String;
Count : in Natural;
Pad : in Character := Space;
Drop : in Truncation := Error);
function Tail
(Source : in Bounded_String;
Count : in Natural;
Pad : in Character := Space;
Drop : in Truncation := Error)
return Bounded_String;
procedure Tail
(Source : in out Bounded_String;
Count : in Natural;
Pad : in Character := Space;
Drop : in Truncation := Error);
------------------------------------
-- String Constructor Subprograms --
------------------------------------
function "*"
(Left : in Natural;
Right : in Character)
return Bounded_String;
function "*"
(Left : in Natural;
Right : in String)
return Bounded_String;
function "*"
(Left : in Natural;
Right : in Bounded_String)
return Bounded_String;
function Replicate
(Count : in Natural;
Item : in Character;
Drop : in Truncation := Error)
return Bounded_String;
function Replicate
(Count : in Natural;
Item : in String;
Drop : in Truncation := Error)
return Bounded_String;
function Replicate
(Count : in Natural;
Item : in Bounded_String;
Drop : in Truncation := Error)
return Bounded_String;
private
type Bounded_String is record
Length : Length_Range := 0;
Data : String (1 .. Max_Length) := (1 .. Max_Length => ASCII.NUL);
end record;
Null_Bounded_String : constant Bounded_String :=
(Length => 0, Data => (1 .. Max_Length => ASCII.NUL));
-- Pragma Inline declarations (GNAT specific additions)
pragma Inline ("=");
pragma Inline ("<");
pragma Inline ("<=");
pragma Inline (">");
pragma Inline (">=");
pragma Inline ("&");
pragma Inline (Count);
pragma Inline (Element);
pragma Inline (Find_Token);
pragma Inline (Index);
pragma Inline (Index_Non_Blank);
pragma Inline (Length);
pragma Inline (Replace_Element);
pragma Inline (Slice);
pragma Inline (To_Bounded_String);
pragma Inline (To_String);
end Generic_Bounded_Length;
end Ada.Strings.Bounded;

73
gcc/ada/a-stream.ads Normal file
View File

@ -0,0 +1,73 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R E A M S --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992-1997 Free Software Foundation, 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). --
-- --
------------------------------------------------------------------------------
package Ada.Streams is
pragma Pure (Streams);
type Root_Stream_Type is abstract tagged limited private;
type Stream_Element is mod 2 ** Standard'Storage_Unit;
type Stream_Element_Offset is range
-(2 ** (Standard'Address_Size - 1)) ..
+(2 ** (Standard'Address_Size - 1)) - 1;
subtype Stream_Element_Count is
Stream_Element_Offset range 0 .. Stream_Element_Offset'Last;
type Stream_Element_Array is
array (Stream_Element_Offset range <>) of Stream_Element;
procedure Read
(Stream : in out Root_Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is abstract;
procedure Write
(Stream : in out Root_Stream_Type;
Item : in Stream_Element_Array)
is abstract;
private
type Root_Stream_Type is abstract tagged limited null record;
end Ada.Streams;

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