--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.119 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+pragma Polling (Off);
+-- We must turn polling off for this unit, because otherwise we get
+-- elaboration circularities with System.Exception_Tables.
+
+with Ada.Unchecked_Deallocation;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+
+with System; use System;
+with System.Exception_Table; use System.Exception_Table;
+with System.Exceptions; use System.Exceptions;
+with System.Standard_Library; use System.Standard_Library;
+with System.Storage_Elements; use System.Storage_Elements;
+with System.Soft_Links; use System.Soft_Links;
+with System.Machine_State_Operations; use System.Machine_State_Operations;
+with System.Traceback;
+
+with Unchecked_Conversion;
+
+package body Ada.Exceptions is
+
+ procedure builtin_longjmp (buffer : Address; Flag : Integer);
+ pragma No_Return (builtin_longjmp);
+ pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
+
+ pragma Suppress (All_Checks);
+ -- We definitely do not want exceptions occurring within this unit, or
+ -- we are in big trouble. If an exceptional situation does occur, better
+ -- that it not be raised, since raising it can cause confusing chaos.
+
+ type Subprogram_Descriptor_List_Ptr is
+ access all Subprogram_Descriptor_List;
+
+ Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
+ -- This location is initialized by Register_Exceptions to point to a
+ -- list of pointers to procedure descriptors, sorted into ascending
+ -- order of PC addresses.
+ --
+ -- Note that SDP_Table_Build is called *before* this unit (or any
+ -- other unit) is elaborated. That's important, because exceptions can
+ -- and do occur during elaboration of units, and must be handled during
+ -- elaboration. This means that we are counting on the fact that the
+ -- initialization of Subprogram_Descriptors to null is done by the
+ -- load process and NOT by an explicit assignment during elaboration.
+
+ Num_Subprogram_Descriptors : Natural;
+ -- Number of subprogram descriptors, the useful descriptors are stored
+ -- in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There
+ -- can be unused entries at the end of the array due to elimination of
+ -- duplicated entries (which can arise from use of pragma Import).
+
+ Exception_Tracebacks : Integer;
+ pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
+ -- Boolean indicating whether tracebacks should be stored in exception
+ -- occurrences.
+
+ Nline : constant String := String' (1 => ASCII.LF);
+ -- Convenient shortcut
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- Note: the exported subprograms in this package body are called directly
+ -- from C clients using the given external name, even though they are not
+ -- technically visible in the Ada sense.
+
+ procedure AAA;
+ -- Mark start of procedures in this unit
+
+ procedure ZZZ;
+ -- Mark end of procedures in this package
+
+ Address_Image_Length : constant :=
+ 13 + 10 * Boolean'Pos (Standard'Address_Size > 32);
+ -- Length of string returned by Address_Image function
+
+ function Address_Image (A : System.Address) return String;
+ -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
+ -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
+ -- in lower case.
+
+ procedure Free
+ is new Ada.Unchecked_Deallocation
+ (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);
+
+ procedure Raise_Current_Excep (E : Exception_Id);
+ pragma No_Return (Raise_Current_Excep);
+ pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
+ -- This is the lowest level raise routine. It raises the exception
+ -- referenced by Current_Excep.all in the TSD, without deferring
+ -- abort (the caller must ensure that abort is deferred on entry).
+ -- The parameter E is ignored.
+ --
+ -- This external name for Raise_Current_Excep is historical, and probably
+ -- should be changed but for now we keep it, because gdb knows about it.
+ -- The parameter is also present for historical compatibility. ???
+
+ procedure Raise_Exception_No_Defer
+ (E : Exception_Id; Message : String := "");
+ pragma Export (Ada, Raise_Exception_No_Defer,
+ "ada__exceptions__raise_exception_no_defer");
+ pragma No_Return (Raise_Exception_No_Defer);
+ -- Similar to Raise_Exception, but with no abort deferral
+
+ procedure Raise_With_Msg (E : Exception_Id);
+ pragma No_Return (Raise_With_Msg);
+ pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
+ -- Raises an exception with given exception id value. A message
+ -- is associated with the raise, and has already been stored in the
+ -- exception occurrence referenced by the Current_Excep in the TSD.
+ -- Abort is deferred before the raise call.
+
+ procedure Raise_With_Location
+ (E : Exception_Id;
+ F : SSL.Big_String_Ptr;
+ L : Integer);
+ pragma No_Return (Raise_With_Location);
+ -- Raise an exception with given exception id value. A filename and line
+ -- number is associated with the raise and is stored in the exception
+ -- occurrence.
+
+ procedure Raise_Constraint_Error
+ (File : SSL.Big_String_Ptr; Line : Integer);
+ pragma No_Return (Raise_Constraint_Error);
+ pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
+ -- Raise constraint error with file:line information
+
+ procedure Raise_Program_Error
+ (File : SSL.Big_String_Ptr; Line : Integer);
+ pragma No_Return (Raise_Program_Error);
+ pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
+ -- Raise program error with file:line information
+
+ procedure Raise_Storage_Error
+ (File : SSL.Big_String_Ptr; Line : Integer);
+ pragma No_Return (Raise_Storage_Error);
+ pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
+ -- Raise storage error with file:line information
+
+ -- The exception raising process and the automatic tracing mechanism rely
+ -- on some careful use of flags attached to the exception occurrence. The
+ -- graph below illustrates the relations between the Raise_ subprograms
+ -- and identifies the points where basic flags such as Exception_Raised
+ -- are initialized.
+ --
+ -- (i) signs indicate the flags initialization points. R stands for Raise,
+ -- W for With, and E for Exception.
+ --
+ -- R_No_Msg R_E R_Pe R_Ce R_Se
+ -- | | | | |
+ -- +--+ +--+ +---+ | +---+
+ -- | | | | |
+ -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc R_W_C_Msg
+ -- | | | | | |
+ -- +------------+ | +-----------+ +--+ +--+ |
+ -- | | | | | |
+ -- | | | Set_E_C_Msg(i) |
+ -- | | | |
+ -- | | | +--------------------------+
+ -- | | | |
+ -- Raise_Current_Excep
+
+ procedure Reraise;
+ pragma No_Return (Reraise);
+ pragma Export (C, Reraise, "__gnat_reraise");
+ -- Reraises the exception referenced by the Current_Excep field of
+ -- the TSD (all fields of this exception occurrence are set). Abort
+ -- is deferred before the reraise operation.
+
+ function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean;
+ -- Used in call to sort SDP table (SDP_Table_Build), compares two elements
+
+ procedure SDP_Table_Sort_Move (From : Natural; To : Natural);
+ -- Used in call to sort SDP table (SDP_Table_Build), moves one element
+
+ procedure Set_Exception_C_Msg
+ (Id : Exception_Id;
+ Msg : SSL.Big_String_Ptr;
+ Line : Integer := 0);
+ -- This routine is called to setup the exception referenced by the
+ -- Current_Excep field in the TSD to contain the indicated Id value
+ -- and message. Msg is a null terminated string. when Line > 0,
+ -- Msg is the filename and line the line number of the exception location.
+
+ procedure To_Stderr (S : String);
+ pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
+ -- Little routine to output string to stderr that is also used
+ -- in the tasking run time.
+
+ procedure Unhandled_Exception_Terminate;
+ pragma No_Return (Unhandled_Exception_Terminate);
+ -- This procedure is called to terminate execution following an unhandled
+ -- exception. The exception information, including traceback if available
+ -- is output, and execution is then terminated. Note that at the point
+ -- where this routine is called, the stack has typically been destroyed
+
+ ---------------------------------
+ -- Debugger Interface Routines --
+ ---------------------------------
+
+ -- The routines here are null routines that normally have no effect.
+ -- they are provided for the debugger to place breakpoints on their
+ -- entry points to get control on an exception.
+
+ procedure Notify_Exception
+ (Id : Exception_Id;
+ Handler : Code_Loc;
+ Is_Others : Boolean);
+ pragma Export (C, Notify_Exception, "__gnat_notify_exception");
+ -- This routine is called whenever an exception is signalled. The Id
+ -- parameter is the Exception_Id of the exception being raised. The
+ -- second parameter Handler is Null_Loc if the exception is unhandled,
+ -- and is otherwise the entry point of the handler that will handle
+ -- the exception. Is_Others is True if the handler is an others handler
+ -- and False otherwise. In the unhandled exception case, if possible
+ -- (and certainly if zero cost exception handling is active), the
+ -- stack is still intact when this procedure is called. Note that this
+ -- routine is entered before any finalization handlers are entered if
+ -- the exception is unhandled by a "real" exception handler.
+
+ procedure Unhandled_Exception;
+ pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
+ -- This routine is called in addition to Notify_Exception in the
+ -- unhandled exception case. The fact that there are two routines
+ -- which are somewhat redundant is historical. Notify_Exception
+ -- certainly is complete enough, but GDB still uses this routine.
+
+ ---------------------------------------
+ -- Exception backtracing subprograms --
+ ---------------------------------------
+
+ -- What is automatically output when exception tracing is on basically
+ -- corresponds to the usual exception information, but with the call
+ -- chain backtrace possibly tailored by a backtrace decorator. Modifying
+ -- Exception_Information itself is not a good idea because the decorated
+ -- output is completely out of control and would break all our code
+ -- related to the streaming of exceptions.
+ --
+ -- We then provide an alternative function to Exception_Information to
+ -- compute the possibly tailored output, which is equivalent if no
+ -- decorator is currently set :
+
+ function Tailored_Exception_Information
+ (X : Exception_Occurrence)
+ return String;
+ -- Exception information to be output in the case of automatic tracing
+ -- requested through GNAT.Exception_Traces.
+ --
+ -- This is the same as Exception_Information if no backtrace decorator
+ -- is currently in place. Otherwise, this is Exception_Information with
+ -- the call chain raw addresses replaced by the result of a call to the
+ -- current decorator provided with the call chain addresses.
+
+ pragma Export
+ (Ada, Tailored_Exception_Information,
+ "__gnat_tailored_exception_information");
+ -- This function is used within this package but also from within
+ -- System.Tasking.Stages.
+ --
+ -- The output of Exception_Information and Tailored_Exception_Information
+ -- share a common part which was formerly built using local procedures
+ -- within Exception_Information. These procedures have been extracted from
+ -- their original place to be available to Tailored_Exception_Information
+ -- also.
+ --
+ -- Each of these procedures appends some input to an information string
+ -- currently being built. The Ptr argument represents the last position
+ -- in this string at which a character has been written.
+
+ procedure Append_Info_Nat
+ (N : Natural;
+ Info : in out String;
+ Ptr : in out Natural);
+ -- Append the image of N at the end of the provided information string.
+
+ procedure Append_Info_NL
+ (Info : in out String;
+ Ptr : in out Natural);
+ -- Append a CR/LF couple at the end of the provided information string.
+
+ procedure Append_Info_String
+ (S : String;
+ Info : in out String;
+ Ptr : in out Natural);
+ -- Append a string at the end of the provided information string.
+
+ -- To build Exception_Information and Tailored_Exception_Information,
+ -- we then use three intermediate functions :
+
+ function Basic_Exception_Information
+ (X : Exception_Occurrence)
+ return String;
+ -- Returns the basic exception information string associated with a
+ -- given exception occurrence. This is the common part shared by both
+ -- Exception_Information and Tailored_Exception_Infomation.
+
+ function Basic_Exception_Traceback
+ (X : Exception_Occurrence)
+ return String;
+ -- Returns an image of the complete call chain associated with an
+ -- exception occurence in its most basic form, that is as a raw sequence
+ -- of hexadecimal binary addresses.
+
+ function Tailored_Exception_Traceback
+ (X : Exception_Occurrence)
+ return String;
+ -- Returns an image of the complete call chain associated with an
+ -- exception occurrence, either in its basic form if no decorator is
+ -- in place, or as formatted by the decorator otherwise.
+
+ -- The overall organization of the exception information related code
+ -- is summarized below :
+ --
+ -- Exception_Information
+ -- |
+ -- +-------+--------+
+ -- | |
+ -- Basic_Exc_Info & Basic_Exc_Tback
+ --
+ --
+ -- Tailored_Exception_Information
+ -- |
+ -- +----------+----------+
+ -- | |
+ -- Basic_Exc_Info & Tailored_Exc_Tback
+ -- |
+ -- +-----------+------------+
+ -- | |
+ -- Basic_Exc_Tback Or Tback_Decorator
+ -- if no decorator set otherwise
+
+ --------------------------------
+ -- Import Run-Time C Routines --
+ --------------------------------
+
+ -- The purpose of the following pragma Imports is to ensure that we
+ -- generate appropriate subprogram descriptors for all C routines in
+ -- the standard GNAT library that can raise exceptions. This ensures
+ -- that the exception propagation can properly find these routines
+
+ pragma Warnings (Off); -- so old compiler does not complain
+ pragma Propagate_Exceptions;
+
+ procedure Unhandled_Terminate;
+ pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
+
+ procedure Propagate_Exception (Mstate : Machine_State);
+ pragma No_Return (Propagate_Exception);
+ -- This procedure propagates the exception represented by the occurrence
+ -- referenced by Current_Excep in the TSD for the current task. M is
+ -- the initial machine state, representing the site of the exception
+ -- raise operation. Propagate_Exception searches the exception tables
+ -- for an applicable handler, calling Pop_Frame as needed. If and when
+ -- it locates an applicable handler Propagate_Exception makes a call
+ -- to Enter_Handler to actually enter the handler. If the search is
+ -- unable to locate an applicable handler, execution is terminated by
+ -- calling Unhandled_Exception_Terminate.
+
+ procedure Call_Chain (Excep : EOA);
+ -- Store up to Max_Tracebacks in Excep, corresponding to the current
+ -- call chain.
+
+ -----------------------
+ -- Polling Interface --
+ -----------------------
+
+ type Unsigned is mod 2 ** 32;
+
+ Counter : Unsigned := 0;
+ -- This counter is provided for convenience. It can be used in Poll to
+ -- perform periodic but not systematic operations.
+
+ procedure Poll is separate;
+ -- The actual polling routine is separate, so that it can easily
+ -- be replaced with a target dependent version.
+
+ ---------
+ -- AAA --
+ ---------
+
+ -- This dummy procedure gives us the start of the PC range for addresses
+ -- within the exception unit itself. We hope that gigi/gcc keep all the
+ -- procedures in their original order!
+
+ procedure AAA is
+ begin
+ null;
+ end AAA;
+
+ -------------------
+ -- Address_Image --
+ -------------------
+
+ function Address_Image (A : Address) return String is
+ S : String (1 .. 18);
+ P : Natural;
+ N : Integer_Address;
+
+ H : constant array (Integer range 0 .. 15) of Character :=
+ "0123456789abcdef";
+ begin
+ P := S'Last;
+ N := To_Integer (A);
+ while N /= 0 loop
+ S (P) := H (Integer (N mod 16));
+ P := P - 1;
+ N := N / 16;
+ end loop;
+
+ S (P - 1) := '0';
+ S (P) := 'x';
+ return S (P - 1 .. S'Last);
+ end Address_Image;
+
+ ---------------------
+ -- Append_Info_Nat --
+ ---------------------
+
+ procedure Append_Info_Nat
+ (N : Natural;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ if N > 9 then
+ Append_Info_Nat (N / 10, Info, Ptr);
+ end if;
+
+ Ptr := Ptr + 1;
+ Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
+ end Append_Info_Nat;
+
+ --------------------
+ -- Append_Info_NL --
+ --------------------
+
+ procedure Append_Info_NL
+ (Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ Ptr := Ptr + 1;
+ Info (Ptr) := ASCII.CR;
+ Ptr := Ptr + 1;
+ Info (Ptr) := ASCII.LF;
+ end Append_Info_NL;
+
+ ------------------------
+ -- Append_Info_String --
+ ------------------------
+
+ procedure Append_Info_String
+ (S : String;
+ Info : in out String;
+ Ptr : in out Natural)
+ is
+ begin
+ Info (Ptr + 1 .. Ptr + S'Length) := S;
+ Ptr := Ptr + S'Length;
+ end Append_Info_String;
+
+ ---------------------------------
+ -- Basic_Exception_Information --
+ ---------------------------------
+
+ function Basic_Exception_Information
+ (X : Exception_Occurrence)
+ return String
+ is
+ Name : constant String := Exception_Name (X);
+ Msg : constant String := Exception_Message (X);
+ -- Exception name and message that are going to be included in the
+ -- information to return, if not empty.
+
+ Name_Len : constant Natural := Name'Length;
+ Msg_Len : constant Natural := Msg'Length;
+ -- Length of these strings, useful to compute the size of the string
+ -- we have to allocate for the complete result as well as in the body
+ -- of this procedure.
+
+ Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
+ -- Maximum length of the information string we will build, with :
+ --
+ -- 50 = 16 + 2 for the text associated with the name
+ -- + 9 + 2 for the text associated with the message
+ -- + 5 + 2 for the text associated with the pid
+ -- + 14 for the text image of the pid itself and a margin.
+ --
+ -- This is indeed a maximum since some data may not appear at all if
+ -- not relevant. For example, nothing related to the exception message
+ -- will be there if this message is empty.
+ --
+ -- WARNING : Do not forget to update these numbers if anything
+ -- involved in the computation changes.
+
+ Info : String (1 .. Info_Maxlen);
+ -- Information string we are going to build, containing the common
+ -- part shared by Exc_Info and Tailored_Exc_Info.
+
+ Ptr : Natural := 0;
+
+ begin
+ -- Output exception name and message except for _ABORT_SIGNAL, where
+ -- these two lines are omitted (see discussion above).
+
+ if Name (1) /= '_' then
+ Append_Info_String ("Exception name: ", Info, Ptr);
+ Append_Info_String (Name, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+
+ if Msg_Len /= 0 then
+ Append_Info_String ("Message: ", Info, Ptr);
+ Append_Info_String (Msg, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+ end if;
+ end if;
+
+ -- Output PID line if non-zero
+
+ if X.Pid /= 0 then
+ Append_Info_String ("PID: ", Info, Ptr);
+ Append_Info_Nat (X.Pid, Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+ end if;
+
+ return Info (1 .. Ptr);
+ end Basic_Exception_Information;
+
+ -------------------------------
+ -- Basic_Exception_Traceback --
+ -------------------------------
+
+ function Basic_Exception_Traceback
+ (X : Exception_Occurrence)
+ return String
+ is
+ Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
+ -- Maximum length of the information string we are building, with :
+ -- 33 = 31 + 4 for the text before and after the traceback, and
+ -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ")
+ --
+ -- WARNING : Do not forget to update these numbers if anything
+ -- involved in the computation changes.
+
+ Info : String (1 .. Info_Maxlen);
+ -- Information string we are going to build, containing an image
+ -- of the call chain associated with the exception occurrence in its
+ -- most basic form, that is as a sequence of binary addresses.
+
+ Ptr : Natural := 0;
+
+ begin
+ if X.Num_Tracebacks > 0 then
+ Append_Info_String ("Call stack traceback locations:", Info, Ptr);
+ Append_Info_NL (Info, Ptr);
+
+ for J in 1 .. X.Num_Tracebacks loop
+ Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr);
+ exit when J = X.Num_Tracebacks;
+ Append_Info_String (" ", Info, Ptr);
+ end loop;
+
+ Append_Info_NL (Info, Ptr);
+ end if;
+
+ return Info (1 .. Ptr);
+ end Basic_Exception_Traceback;
+
+ -----------------
+ -- Break_Start --
+ -----------------
+
+ procedure Break_Start is
+ begin
+ null;
+ end Break_Start;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain (Excep : EOA) is
+ begin
+ if Excep.Num_Tracebacks /= 0 then
+ -- This is a reraise, no need to store a new (wrong) chain.
+ return;
+ end if;
+
+ System.Traceback.Call_Chain
+ (Excep.Tracebacks'Address,
+ Max_Tracebacks,
+ Excep.Num_Tracebacks,
+ AAA'Address,
+ ZZZ'Address);
+ end Call_Chain;
+
+ ------------------------------
+ -- Current_Target_Exception --
+ ------------------------------
+
+ function Current_Target_Exception return Exception_Occurrence is
+ begin
+ return Null_Occurrence;
+ end Current_Target_Exception;
+
+ -------------------
+ -- EId_To_String --
+ -------------------
+
+ function EId_To_String (X : Exception_Id) return String is
+ begin
+ if X = Null_Id then
+ return "";
+ else
+ return Exception_Name (X);
+ end if;
+ end EId_To_String;
+
+ ------------------
+ -- EO_To_String --
+ ------------------
+
+ -- We use the null string to represent the null occurrence, otherwise
+ -- we output the Exception_Information string for the occurrence.
+
+ function EO_To_String (X : Exception_Occurrence) return String is
+ begin
+ if X.Id = Null_Id then
+ return "";
+ else
+ return Exception_Information (X);
+ end if;
+ end EO_To_String;
+
+ ------------------------
+ -- Exception_Identity --
+ ------------------------
+
+ function Exception_Identity
+ (X : Exception_Occurrence)
+ return Exception_Id
+ is
+ begin
+ if X.Id = Null_Id then
+ raise Constraint_Error;
+ else
+ return X.Id;
+ end if;
+ end Exception_Identity;
+
+ ---------------------------
+ -- Exception_Information --
+ ---------------------------
+
+ -- The format of the string is:
+
+ -- Exception_Name: nnnnn
+ -- Message: mmmmm
+ -- PID: ppp
+ -- Call stack traceback locations:
+ -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh
+
+ -- where
+
+ -- nnnn is the fully qualified name of the exception in all upper
+ -- case letters. This line is always present.
+
+ -- mmmm is the message (this line present only if message is non-null)
+
+ -- ppp is the Process Id value as a decimal integer (this line is
+ -- present only if the Process Id is non-zero). Currently we are
+ -- not making use of this field.
+
+ -- The Call stack traceback locations line and the following values
+ -- are present only if at least one traceback location was recorded.
+ -- the values are given in C style format, with lower case letters
+ -- for a-f, and only as many digits present as are necessary.
+
+ -- The line terminator sequence at the end of each line, including the
+ -- last line is a CR-LF sequence (16#0D# followed by 16#0A#).
+
+ -- The Exception_Name and Message lines are omitted in the abort
+ -- signal case, since this is not really an exception, and the only
+ -- use of this routine is internal for printing termination output.
+
+ -- WARNING: if the format of the generated string is changed, please note
+ -- that an equivalent modification to the routine String_To_EO must be
+ -- made to preserve proper functioning of the stream attributes.
+
+ function Exception_Information (X : Exception_Occurrence) return String is
+
+ -- This information is now built using the circuitry introduced in
+ -- association with the support of traceback decorators, as the
+ -- catenation of the exception basic information and the call chain
+ -- backtrace in its basic form.
+
+ Basic_Info : constant String := Basic_Exception_Information (X);
+ Tback_Info : constant String := Basic_Exception_Traceback (X);
+
+ Basic_Len : constant Natural := Basic_Info'Length;
+ Tback_Len : constant Natural := Tback_Info'Length;
+
+ Info : String (1 .. Basic_Len + Tback_Len);
+ Ptr : Natural := 0;
+
+ begin
+ Append_Info_String (Basic_Info, Info, Ptr);
+ Append_Info_String (Tback_Info, Info, Ptr);
+
+ return Info;
+ end Exception_Information;
+
+ -----------------------
+ -- Exception_Message --
+ -----------------------
+
+ function Exception_Message (X : Exception_Occurrence) return String is
+ begin
+ if X.Id = Null_Id then
+ raise Constraint_Error;
+ end if;
+
+ return X.Msg (1 .. X.Msg_Length);
+ end Exception_Message;
+
+ --------------------
+ -- Exception_Name --
+ --------------------
+
+ function Exception_Name (Id : Exception_Id) return String is
+ begin
+ if Id = null then
+ raise Constraint_Error;
+ end if;
+
+ return Id.Full_Name.all (1 .. Id.Name_Length - 1);
+ end Exception_Name;
+
+ function Exception_Name (X : Exception_Occurrence) return String is
+ begin
+ return Exception_Name (X.Id);
+ end Exception_Name;
+
+ ---------------------------
+ -- Exception_Name_Simple --
+ ---------------------------
+
+ function Exception_Name_Simple (X : Exception_Occurrence) return String is
+ Name : constant String := Exception_Name (X);
+ P : Natural;
+
+ begin
+ P := Name'Length;
+ while P > 1 loop
+ exit when Name (P - 1) = '.';
+ P := P - 1;
+ end loop;
+
+ return Name (P .. Name'Length);
+ end Exception_Name_Simple;
+
+ -------------------------
+ -- Propagate_Exception --
+ -------------------------
+
+ procedure Propagate_Exception (Mstate : Machine_State) is
+ Excep : constant EOA := Get_Current_Excep.all;
+ Loc : Code_Loc;
+ Lo, Hi : Natural;
+ Pdesc : Natural;
+ Hrec : Handler_Record_Ptr;
+ Info : Subprogram_Info_Type;
+
+ type Machine_State_Record is
+ new Storage_Array (1 .. Machine_State_Length);
+ for Machine_State_Record'Alignment use Standard'Maximum_Alignment;
+
+ procedure Duplicate_Machine_State (Dest, Src : Machine_State);
+ -- Copy Src into Dest, assuming that a Machine_State is pointing to
+ -- an area of Machine_State_Length bytes.
+
+ procedure Duplicate_Machine_State (Dest, Src : Machine_State) is
+ type Machine_State_Record_Access is access Machine_State_Record;
+ function To_MSR is new Unchecked_Conversion
+ (Machine_State, Machine_State_Record_Access);
+
+ begin
+ To_MSR (Dest).all := To_MSR (Src).all;
+ end Duplicate_Machine_State;
+
+ -- Data for handling the finalization handler case. A simple approach
+ -- in this routine would simply to unwind stack frames till we find a
+ -- handler and then enter it. But this is undesirable in the case where
+ -- we have only finalization handlers, and no "real" handler, i.e. a
+ -- case where we have an unhandled exception.
+
+ -- In this case we prefer to signal unhandled exception with the stack
+ -- intact, and entering finalization handlers would destroy the stack
+ -- state. To deal with this, as we unwind the stack, we note the first
+ -- finalization handler, and remember it in the following variables.
+ -- We then continue to unwind. If and when we find a "real", i.e. non-
+ -- finalization handler, then we use these variables to pass control to
+ -- the finalization handler.
+
+ FH_Found : Boolean := False;
+ -- Set when a finalization handler is found
+
+ FH_Mstate : aliased Machine_State_Record;
+ -- Records the machine state for the finalization handler
+
+ FH_Handler : Code_Loc;
+ -- Record handler address for finalization handler
+
+ FH_Num_Trb : Natural;
+ -- Save number of tracebacks for finalization handler
+
+ begin
+ -- Loop through stack frames as exception propagates
+
+ Main_Loop : loop
+ Loc := Get_Code_Loc (Mstate);
+ exit Main_Loop when Loc = Null_Loc;
+
+ -- Record location unless it is inside this unit. Note: this
+ -- test should really say Code_Address, but Address is the same
+ -- as Code_Address for unnested subprograms, and Code_Address
+ -- would cause a bootstrap problem
+
+ if Loc < AAA'Address or else Loc > ZZZ'Address then
+
+ -- Record location unless we already recorded max tracebacks
+
+ if Excep.Num_Tracebacks /= Max_Tracebacks then
+
+ -- Do not record location if it is the return point from
+ -- a reraise call from within a cleanup handler
+
+ if not Excep.Cleanup_Flag then
+ Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1;
+ Excep.Tracebacks (Excep.Num_Tracebacks) := Loc;
+
+ -- For reraise call from cleanup handler, skip entry and
+ -- clear the flag so that we will start to record again
+
+ else
+ Excep.Cleanup_Flag := False;
+ end if;
+ end if;
+ end if;
+
+ -- Do binary search on procedure table
+
+ Lo := 1;
+ Hi := Num_Subprogram_Descriptors;
+
+ -- Binary search loop
+
+ loop
+ Pdesc := (Lo + Hi) / 2;
+
+ -- Note that Loc is expected to be the procedure's call point
+ -- and not the return point.
+
+ if Loc < Subprogram_Descriptors (Pdesc).Code then
+ Hi := Pdesc - 1;
+
+ elsif Pdesc < Num_Subprogram_Descriptors
+ and then Loc > Subprogram_Descriptors (Pdesc + 1).Code
+ then
+ Lo := Pdesc + 1;
+
+ else
+ exit;
+ end if;
+
+ -- This happens when the current Loc is completely outside of
+ -- the range of the program, which usually means that we reached
+ -- the top level frame (e.g __start). In this case we have an
+ -- unhandled exception.
+
+ exit Main_Loop when Hi < Lo;
+ end loop;
+
+ -- Come here with Subprogram_Descriptors (Pdesc) referencing the
+ -- procedure descriptor that applies to this PC value. Now do a
+ -- serial search to see if any handler is applicable to this PC
+ -- value, and to the exception that we are propagating
+
+ for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop
+ Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J);
+
+ if Loc >= Hrec.Lo and then Loc < Hrec.Hi then
+
+ -- PC range is applicable, see if handler is for this exception
+
+ -- First test for case of "all others" (finalization) handler.
+ -- We do not enter such a handler until we are sure there is
+ -- a real handler further up the stack.
+
+ if Hrec.Id = All_Others_Id then
+
+ -- If this is the first finalization handler, then
+ -- save the machine state so we can enter it later
+ -- without having to repeat the search.
+
+ if not FH_Found then
+ FH_Found := True;
+ Duplicate_Machine_State
+ (Machine_State (FH_Mstate'Address), Mstate);
+ FH_Handler := Hrec.Handler;
+ FH_Num_Trb := Excep.Num_Tracebacks;
+ end if;
+
+ -- Normal (non-finalization exception with matching Id)
+
+ elsif Excep.Id = Hrec.Id
+ or else (Hrec.Id = Others_Id
+ and not Excep.Id.Not_Handled_By_Others)
+ then
+ -- Notify the debugger that we have found a handler
+ -- and are about to propagate an exception.
+
+ Notify_Exception
+ (Excep.Id, Hrec.Handler, Hrec.Id = Others_Id);
+
+ -- Output some exception information if necessary, as
+ -- specified by GNAT.Exception_Traces. Take care not to
+ -- output information about internal exceptions.
+ --
+ -- ??? The traceback entries we have at this point only
+ -- consist in the ones we stored while walking up the
+ -- stack *up to the handler*. All the frames above the
+ -- subprogram in which the handler is found are missing.
+
+ if Exception_Trace = Every_Raise
+ and then not Excep.Id.Not_Handled_By_Others
+ then
+ To_Stderr (Nline);
+ To_Stderr ("Exception raised");
+ To_Stderr (Nline);
+ To_Stderr (Tailored_Exception_Information (Excep.all));
+ end if;
+
+ -- If we already encountered a finalization handler, then
+ -- reset the context to that handler, and enter it.
+
+ if FH_Found then
+ Excep.Num_Tracebacks := FH_Num_Trb;
+ Excep.Cleanup_Flag := True;
+
+ Enter_Handler
+ (Machine_State (FH_Mstate'Address), FH_Handler);
+
+ -- If we have not encountered a finalization handler,
+ -- then enter the current handler.
+
+ else
+ Enter_Handler (Mstate, Hrec.Handler);
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ Info := Subprogram_Descriptors (Pdesc).Subprogram_Info;
+ exit Main_Loop when Info = No_Info;
+ Pop_Frame (Mstate, Info);
+ end loop Main_Loop;
+
+ -- Fall through if no "real" exception handler found. First thing
+ -- is to call the dummy Unhandled_Exception routine with the stack
+ -- intact, so that the debugger can get control.
+
+ Unhandled_Exception;
+
+ -- Also make the appropriate Notify_Exception call for the debugger.
+
+ Notify_Exception (Excep.Id, Null_Loc, False);
+
+ -- If there were finalization handlers, then enter the top one.
+ -- Just because there is no handler does not mean we don't have
+ -- to still execute all finalizations and cleanups before
+ -- terminating. Note that the process of calling cleanups
+ -- does not disturb the back trace stack, since he same
+ -- exception occurrence gets reraised, and new traceback
+ -- entries added as we go along.
+
+ if FH_Found then
+ Excep.Num_Tracebacks := FH_Num_Trb;
+ Excep.Cleanup_Flag := True;
+ Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler);
+ end if;
+
+ -- If no cleanups, then this is the real unhandled termination
+
+ Unhandled_Exception_Terminate;
+
+ end Propagate_Exception;
+
+ -------------------------
+ -- Raise_Current_Excep --
+ -------------------------
+
+ procedure Raise_Current_Excep (E : Exception_Id) is
+
+ pragma Inspection_Point (E);
+ -- This is so the debugger can reliably inspect the parameter
+
+ Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
+ Mstate_Ptr : constant Machine_State :=
+ Machine_State (Get_Machine_State_Addr.all);
+ Excep : EOA;
+
+ begin
+ -- WARNING : There should be no exception handler for this body
+ -- because this would cause gigi to prepend a setup for a new
+ -- jmpbuf to the sequence of statements. We would then always get
+ -- this new buf in Jumpbuf_Ptr instead of the one for the exception
+ -- we are handling, which would completely break the whole design
+ -- of this procedure.
+
+ -- If the jump buffer pointer is non-null, it means that a jump
+ -- buffer was allocated (obviously that happens only in the case
+ -- of zero cost exceptions not implemented, or if a jump buffer
+ -- was manually set up by C code).
+
+ if Jumpbuf_Ptr /= Null_Address then
+ Excep := Get_Current_Excep.all;
+
+ if Exception_Tracebacks /= 0 then
+ Call_Chain (Excep);
+ end if;
+
+ if not Excep.Exception_Raised then
+ -- This is not a reraise.
+
+ Excep.Exception_Raised := True;
+
+ -- Output some exception information if necessary, as specified
+ -- by GNAT.Exception_Traces. Take care not to output information
+ -- about internal exceptions.
+
+ if Exception_Trace = Every_Raise
+ and then not Excep.Id.Not_Handled_By_Others
+ then
+ begin
+ -- This is in a block because of the call to
+ -- Tailored_Exception_Information which might
+ -- require an exception handler for secondary
+ -- stack cleanup.
+
+ To_Stderr (Nline);
+ To_Stderr ("Exception raised");
+ To_Stderr (Nline);
+ To_Stderr (Tailored_Exception_Information (Excep.all));
+ end;
+ end if;
+ end if;
+
+ builtin_longjmp (Jumpbuf_Ptr, 1);
+
+ -- If we have no jump buffer, then either zero cost exception
+ -- handling is in place, or we have no handlers anyway. In
+ -- either case we have an unhandled exception. If zero cost
+ -- exception handling is in place, propagate the exception
+
+ elsif Subprogram_Descriptors /= null then
+ Set_Machine_State (Mstate_Ptr);
+ Propagate_Exception (Mstate_Ptr);
+
+ -- Otherwise, we know the exception is unhandled by the absence
+ -- of an allocated jump buffer. Note that this means that we also
+ -- have no finalizations to do other than at the outer level.
+
+ else
+ if Exception_Tracebacks /= 0 then
+ Call_Chain (Get_Current_Excep.all);
+ end if;
+
+ Unhandled_Exception;
+ Notify_Exception (E, Null_Loc, False);
+ Unhandled_Exception_Terminate;
+ end if;
+ end Raise_Current_Excep;
+
+ ---------------------
+ -- Raise_Exception --
+ ---------------------
+
+ procedure Raise_Exception
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ Len : constant Natural :=
+ Natural'Min (Message'Length, Exception_Msg_Max_Length);
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ if E /= null then
+ Excep.Msg_Length := Len;
+ Excep.Msg (1 .. Len) := Message (1 .. Len);
+ Raise_With_Msg (E);
+ end if;
+ end Raise_Exception;
+
+ ----------------------------
+ -- Raise_Exception_Always --
+ ----------------------------
+
+ procedure Raise_Exception_Always
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ Len : constant Natural :=
+ Natural'Min (Message'Length, Exception_Msg_Max_Length);
+
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Excep.Msg_Length := Len;
+ Excep.Msg (1 .. Len) := Message (1 .. Len);
+ Raise_With_Msg (E);
+ end Raise_Exception_Always;
+
+ -------------------------------
+ -- Raise_From_Signal_Handler --
+ -------------------------------
+
+ procedure Raise_From_Signal_Handler
+ (E : Exception_Id;
+ M : SSL.Big_String_Ptr)
+ is
+ Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
+ Mstate_Ptr : constant Machine_State :=
+ Machine_State (Get_Machine_State_Addr.all);
+
+ begin
+ Set_Exception_C_Msg (E, M);
+ Abort_Defer.all;
+
+ -- Now we raise the exception. The following code is essentially
+ -- identical to the Raise_Current_Excep routine, except that in the
+ -- zero cost exception case, we do not call Set_Machine_State, since
+ -- the signal handler that passed control here has already set the
+ -- machine state directly.
+ --
+ -- ??? Updates related to the implementation of automatic backtraces
+ -- have not been done here. Some action will be required when dealing
+ -- the remaining problems in ZCX mode (incomplete backtraces so far).
+
+ -- If the jump buffer pointer is non-null, it means that a jump
+ -- buffer was allocated (obviously that happens only in the case
+ -- of zero cost exceptions not implemented, or if a jump buffer
+ -- was manually set up by C code).
+
+ if Jumpbuf_Ptr /= Null_Address then
+ builtin_longjmp (Jumpbuf_Ptr, 1);
+
+ -- If we have no jump buffer, then either zero cost exception
+ -- handling is in place, or we have no handlers anyway. In
+ -- either case we have an unhandled exception. If zero cost
+ -- exception handling is in place, propagate the exception
+
+ elsif Subprogram_Descriptors /= null then
+ Propagate_Exception (Mstate_Ptr);
+
+ -- Otherwise, we know the exception is unhandled by the absence
+ -- of an allocated jump buffer. Note that this means that we also
+ -- have no finalizations to do other than at the outer level.
+
+ else
+ Unhandled_Exception;
+ Unhandled_Exception_Terminate;
+ end if;
+ end Raise_From_Signal_Handler;
+
+ ------------------
+ -- Raise_No_Msg --
+ ------------------
+
+ procedure Raise_No_Msg (E : Exception_Id) is
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Excep.Msg_Length := 0;
+ Raise_With_Msg (E);
+ end Raise_No_Msg;
+
+ -------------------------
+ -- Raise_With_Location --
+ -------------------------
+
+ procedure Raise_With_Location
+ (E : Exception_Id;
+ F : SSL.Big_String_Ptr;
+ L : Integer) is
+ begin
+ Set_Exception_C_Msg (E, F, L);
+ Abort_Defer.all;
+ Raise_Current_Excep (E);
+ end Raise_With_Location;
+
+ ----------------------------
+ -- Raise_Constraint_Error --
+ ----------------------------
+
+ procedure Raise_Constraint_Error
+ (File : SSL.Big_String_Ptr; Line : Integer) is
+ begin
+ Raise_With_Location (Constraint_Error_Def'Access, File, Line);
+ end Raise_Constraint_Error;
+
+ -------------------------
+ -- Raise_Program_Error --
+ -------------------------
+
+ procedure Raise_Program_Error
+ (File : SSL.Big_String_Ptr; Line : Integer) is
+ begin
+ Raise_With_Location (Program_Error_Def'Access, File, Line);
+ end Raise_Program_Error;
+
+ -------------------------
+ -- Raise_Storage_Error --
+ -------------------------
+
+ procedure Raise_Storage_Error
+ (File : SSL.Big_String_Ptr; Line : Integer) is
+ begin
+ Raise_With_Location (Storage_Error_Def'Access, File, Line);
+ end Raise_Storage_Error;
+
+ ----------------------
+ -- Raise_With_C_Msg --
+ ----------------------
+
+ procedure Raise_With_C_Msg
+ (E : Exception_Id;
+ M : SSL.Big_String_Ptr) is
+ begin
+ Set_Exception_C_Msg (E, M);
+ Abort_Defer.all;
+ Raise_Current_Excep (E);
+ end Raise_With_C_Msg;
+
+ --------------------
+ -- Raise_With_Msg --
+ --------------------
+
+ procedure Raise_With_Msg (E : Exception_Id) is
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Excep.Exception_Raised := False;
+ Excep.Id := E;
+ Excep.Num_Tracebacks := 0;
+ Excep.Cleanup_Flag := False;
+ Excep.Pid := Local_Partition_ID;
+ Abort_Defer.all;
+ Raise_Current_Excep (E);
+ end Raise_With_Msg;
+
+ -------------
+ -- Reraise --
+ -------------
+
+ procedure Reraise is
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Abort_Defer.all;
+ Raise_Current_Excep (Excep.Id);
+ end Reraise;
+
+ ------------------------
+ -- Reraise_Occurrence --
+ ------------------------
+
+ procedure Reraise_Occurrence (X : Exception_Occurrence) is
+ begin
+ if X.Id /= null then
+ Abort_Defer.all;
+ Save_Occurrence (Get_Current_Excep.all.all, X);
+ Raise_Current_Excep (X.Id);
+ end if;
+ end Reraise_Occurrence;
+
+ -------------------------------
+ -- Reraise_Occurrence_Always --
+ -------------------------------
+
+ procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
+ begin
+ Abort_Defer.all;
+ Save_Occurrence (Get_Current_Excep.all.all, X);
+ Raise_Current_Excep (X.Id);
+ end Reraise_Occurrence_Always;
+
+ ---------------------------------
+ -- Reraise_Occurrence_No_Defer --
+ ---------------------------------
+
+ procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
+ begin
+ Save_Occurrence (Get_Current_Excep.all.all, X);
+ Raise_Current_Excep (X.Id);
+ end Reraise_Occurrence_No_Defer;
+
+ ---------------------
+ -- Save_Occurrence --
+ ---------------------
+
+ procedure Save_Occurrence
+ (Target : out Exception_Occurrence;
+ Source : Exception_Occurrence)
+ is
+ begin
+ Target.Id := Source.Id;
+ Target.Msg_Length := Source.Msg_Length;
+ Target.Num_Tracebacks := Source.Num_Tracebacks;
+ Target.Pid := Source.Pid;
+ Target.Cleanup_Flag := Source.Cleanup_Flag;
+
+ Target.Msg (1 .. Target.Msg_Length) :=
+ Source.Msg (1 .. Target.Msg_Length);
+
+ Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
+ Source.Tracebacks (1 .. Target.Num_Tracebacks);
+ end Save_Occurrence;
+
+ function Save_Occurrence
+ (Source : Exception_Occurrence)
+ return EOA
+ is
+ Target : EOA := new Exception_Occurrence;
+
+ begin
+ Save_Occurrence (Target.all, Source);
+ return Target;
+ end Save_Occurrence;
+
+ ---------------------
+ -- SDP_Table_Build --
+ ---------------------
+
+ procedure SDP_Table_Build
+ (SDP_Addresses : System.Address;
+ SDP_Count : Natural;
+ Elab_Addresses : System.Address;
+ Elab_Addr_Count : Natural)
+ is
+ type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr;
+ type SDLP_Array_Ptr is access all SDLP_Array;
+
+ function To_SDLP_Array_Ptr is new Unchecked_Conversion
+ (System.Address, SDLP_Array_Ptr);
+
+ T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses);
+
+ type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc;
+ type Elab_Array_Ptr is access all Elab_Array;
+
+ function To_Elab_Array_Ptr is new Unchecked_Conversion
+ (System.Address, Elab_Array_Ptr);
+
+ EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses);
+
+ Ndes : Natural;
+ Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
+
+ begin
+ -- If first call, then initialize count of subprogram descriptors
+
+ if Subprogram_Descriptors = null then
+ Num_Subprogram_Descriptors := 0;
+ end if;
+
+ -- First count number of subprogram descriptors. This count includes
+ -- entries with duplicated code addresses (resulting from Import).
+
+ Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count;
+ for J in T'Range loop
+ Ndes := Ndes + T (J).Count;
+ end loop;
+
+ -- Now, allocate the new table (extra zero'th element is for sort call)
+ -- after having saved the previous one
+
+ Previous_Subprogram_Descriptors := Subprogram_Descriptors;
+ Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes);
+
+ -- If there was a previous Subprogram_Descriptors table, copy it back
+ -- into the new one being built. Then free the memory used for the
+ -- previous table.
+
+ for J in 1 .. Num_Subprogram_Descriptors loop
+ Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J);
+ end loop;
+
+ Free (Previous_Subprogram_Descriptors);
+
+ -- Next, append the elaboration routine addresses, building dummy
+ -- SDP's for them as we go through the list.
+
+ Ndes := Num_Subprogram_Descriptors;
+ for J in EA'Range loop
+ Ndes := Ndes + 1;
+ Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0;
+
+ Subprogram_Descriptors (Ndes).all :=
+ Subprogram_Descriptor'
+ (Num_Handlers => 0,
+ Code => Fetch_Code (EA (J)),
+ Subprogram_Info => EA (J),
+ Handler_Records => (1 .. 0 => null));
+ end loop;
+
+ -- Now copy in pointers to SDP addresses of application subprograms
+
+ for J in T'Range loop
+ for K in 1 .. T (J).Count loop
+ Ndes := Ndes + 1;
+ Subprogram_Descriptors (Ndes) := T (J).SDesc (K);
+ Subprogram_Descriptors (Ndes).Code :=
+ Fetch_Code (T (J).SDesc (K).Code);
+ end loop;
+ end loop;
+
+ -- Now we need to sort the table into ascending PC order
+
+ Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access);
+
+ -- Now eliminate duplicate entries. Note that in the case where
+ -- entries have duplicate code addresses, the code for the Lt
+ -- routine ensures that the interesting one (i.e. the one with
+ -- handler entries if there are any) comes first.
+
+ Num_Subprogram_Descriptors := 1;
+
+ for J in 2 .. Ndes loop
+ if Subprogram_Descriptors (J).Code /=
+ Subprogram_Descriptors (Num_Subprogram_Descriptors).Code
+ then
+ Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1;
+ Subprogram_Descriptors (Num_Subprogram_Descriptors) :=
+ Subprogram_Descriptors (J);
+ end if;
+ end loop;
+
+ end SDP_Table_Build;
+
+ -----------------------
+ -- SDP_Table_Sort_Lt --
+ -----------------------
+
+ function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is
+ SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code;
+ SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code;
+
+ begin
+ if SDC1 < SDC2 then
+ return True;
+
+ elsif SDC1 > SDC2 then
+ return False;
+
+ -- For two descriptors for the same procedure, we want the more
+ -- interesting one first. A descriptor with an exception handler
+ -- is more interesting than one without. This happens if the less
+ -- interesting one came from a pragma Import.
+
+ else
+ return Subprogram_Descriptors (Op1).Num_Handlers /= 0
+ and then Subprogram_Descriptors (Op2).Num_Handlers = 0;
+ end if;
+ end SDP_Table_Sort_Lt;
+
+ --------------------------
+ -- SDP_Table_Sort_Move --
+ --------------------------
+
+ procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is
+ begin
+ Subprogram_Descriptors (To) := Subprogram_Descriptors (From);
+ end SDP_Table_Sort_Move;
+
+ -------------------------
+ -- Set_Exception_C_Msg --
+ -------------------------
+
+ procedure Set_Exception_C_Msg
+ (Id : Exception_Id;
+ Msg : Big_String_Ptr;
+ Line : Integer := 0)
+ is
+ Excep : constant EOA := Get_Current_Excep.all;
+ Val : Integer := Line;
+ Remind : Integer;
+ Size : Integer := 1;
+
+ begin
+ Excep.Exception_Raised := False;
+ Excep.Id := Id;
+ Excep.Num_Tracebacks := 0;
+ Excep.Pid := Local_Partition_ID;
+ Excep.Msg_Length := 0;
+ Excep.Cleanup_Flag := False;
+
+ while Msg (Excep.Msg_Length + 1) /= ASCII.NUL
+ and then Excep.Msg_Length < Exception_Msg_Max_Length
+ loop
+ Excep.Msg_Length := Excep.Msg_Length + 1;
+ Excep.Msg (Excep.Msg_Length) := Msg (Excep.Msg_Length);
+ end loop;
+
+ if Line > 0 then
+ -- Compute the number of needed characters
+
+ while Val > 0 loop
+ Val := Val / 10;
+ Size := Size + 1;
+ end loop;
+
+ -- If enough characters are available, put the line number
+
+ if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
+ Excep.Msg (Excep.Msg_Length + 1) := ':';
+ Excep.Msg_Length := Excep.Msg_Length + Size;
+ Val := Line;
+ Size := 0;
+
+ while Val > 0 loop
+ Remind := Val rem 10;
+ Val := Val / 10;
+ Excep.Msg (Excep.Msg_Length - Size) :=
+ Character'Val (Remind + Character'Pos ('0'));
+ Size := Size + 1;
+ end loop;
+ end if;
+ end if;
+ end Set_Exception_C_Msg;
+
+ -------------------
+ -- String_To_EId --
+ -------------------
+
+ function String_To_EId (S : String) return Exception_Id is
+ begin
+ if S = "" then
+ return Null_Id;
+ else
+ return Exception_Id (Internal_Exception (S));
+ end if;
+ end String_To_EId;
+
+ ------------------
+ -- String_To_EO --
+ ------------------
+
+ function String_To_EO (S : String) return Exception_Occurrence is
+ From : Natural;
+ To : Integer;
+
+ X : Exception_Occurrence;
+ -- This is the exception occurrence we will create
+
+ procedure Bad_EO;
+ pragma No_Return (Bad_EO);
+ -- Signal bad exception occurrence string
+
+ procedure Next_String;
+ -- On entry, To points to last character of previous line of the
+ -- message, terminated by CR/LF. On return, From .. To are set to
+ -- specify the next string, or From > To if there are no more lines.
+
+ procedure Bad_EO is
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "bad exception occurrence in stream input");
+ end Bad_EO;
+
+ procedure Next_String is
+ begin
+ From := To + 3;
+
+ if From < S'Last then
+ To := From + 1;
+
+ while To < S'Last - 2 loop
+ if To >= S'Last then
+ Bad_EO;
+ elsif S (To + 1) = ASCII.CR then
+ exit;
+ else
+ To := To + 1;
+ end if;
+ end loop;
+ end if;
+ end Next_String;
+
+ -- Start of processing for String_To_EO
+
+ begin
+ if S = "" then
+ return Null_Occurrence;
+
+ else
+ X.Cleanup_Flag := False;
+
+ To := S'First - 3;
+ Next_String;
+
+ if S (From .. From + 15) /= "Exception name: " then
+ Bad_EO;
+ end if;
+
+ X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
+
+ Next_String;
+
+ if From <= To and then S (From) = 'M' then
+ if S (From .. From + 8) /= "Message: " then
+ Bad_EO;
+ end if;
+
+ X.Msg_Length := To - From - 8;
+ X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
+ Next_String;
+
+ else
+ X.Msg_Length := 0;
+ end if;
+
+ X.Pid := 0;
+
+ if From <= To and then S (From) = 'P' then
+ if S (From .. From + 3) /= "PID:" then
+ Bad_EO;
+ end if;
+
+ From := From + 5; -- skip past PID: space
+
+ while From <= To loop
+ X.Pid := X.Pid * 10 +
+ (Character'Pos (S (From)) - Character'Pos ('0'));
+ From := From + 1;
+ end loop;
+
+ Next_String;
+ end if;
+
+ X.Num_Tracebacks := 0;
+
+ if From <= To then
+ if S (From .. To) /= "Call stack traceback locations:" then
+ Bad_EO;
+ end if;
+
+ Next_String;
+ loop
+ exit when From > To;
+
+ declare
+ Ch : Character;
+ C : Integer_Address;
+ N : Integer_Address;
+
+ begin
+ if S (From) /= '0'
+ or else S (From + 1) /= 'x'
+ then
+ Bad_EO;
+ else
+ From := From + 2;
+ end if;
+
+ C := 0;
+ while From <= To loop
+ Ch := S (From);
+
+ if Ch in '0' .. '9' then
+ N :=
+ Character'Pos (S (From)) - Character'Pos ('0');
+
+ elsif Ch in 'a' .. 'f' then
+ N :=
+ Character'Pos (S (From)) - Character'Pos ('a') + 10;
+
+ elsif Ch = ' ' then
+ From := From + 1;
+ exit;
+
+ else
+ Bad_EO;
+ end if;
+
+ C := C * 16 + N;
+
+ From := From + 1;
+ end loop;
+
+ if X.Num_Tracebacks = Max_Tracebacks then
+ Bad_EO;
+ end if;
+
+ X.Num_Tracebacks := X.Num_Tracebacks + 1;
+ X.Tracebacks (X.Num_Tracebacks) := To_Address (C);
+ end;
+ end loop;
+ end if;
+
+ -- If an exception was converted to a string, it must have
+ -- already been raised, so flag it accordingly and we are done.
+
+ X.Exception_Raised := True;
+ return X;
+ end if;
+ end String_To_EO;
+
+ ----------------------------------
+ -- Tailored_Exception_Traceback --
+ ----------------------------------
+
+ function Tailored_Exception_Traceback
+ (X : Exception_Occurrence)
+ return String
+ is
+ -- We indeed reference the decorator *wrapper* from here and not the
+ -- decorator itself. The purpose of the local variable Wrapper is to
+ -- prevent a potential crash by race condition in the code below. The
+ -- atomicity of this assignment is enforced by pragma Atomic in
+ -- System.Soft_Links.
+
+ -- The potential race condition here, if no local variable was used,
+ -- relates to the test upon the wrapper's value and the call, which
+ -- are not performed atomically. With the local variable, potential
+ -- changes of the wrapper's global value between the test and the
+ -- call become inoffensive.
+
+ Wrapper : constant Traceback_Decorator_Wrapper_Call :=
+ Traceback_Decorator_Wrapper;
+
+ begin
+ if Wrapper = null then
+ return Basic_Exception_Traceback (X);
+ else
+ return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
+ end if;
+ end Tailored_Exception_Traceback;
+
+ ------------------------------------
+ -- Tailored_Exception_Information --
+ ------------------------------------
+
+ function Tailored_Exception_Information
+ (X : Exception_Occurrence)
+ return String
+ is
+ -- The tailored exception information is simply the basic information
+ -- associated with the tailored call chain backtrace.
+
+ Basic_Info : constant String := Basic_Exception_Information (X);
+ Tback_Info : constant String := Tailored_Exception_Traceback (X);
+
+ Basic_Len : constant Natural := Basic_Info'Length;
+ Tback_Len : constant Natural := Tback_Info'Length;
+
+ Info : String (1 .. Basic_Len + Tback_Len);
+ Ptr : Natural := 0;
+
+ begin
+ Append_Info_String (Basic_Info, Info, Ptr);
+ Append_Info_String (Tback_Info, Info, Ptr);
+
+ return Info;
+ end Tailored_Exception_Information;
+
+ -------------------------
+ -- Unhandled_Exception --
+ -------------------------
+
+ procedure Unhandled_Exception is
+ begin
+ null;
+ end Unhandled_Exception;
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception
+ (Id : Exception_Id;
+ Handler : Code_Loc;
+ Is_Others : Boolean)
+ is
+ begin
+ null;
+ end Notify_Exception;
+
+ -----------------------------------
+ -- Unhandled_Exception_Terminate --
+ -----------------------------------
+
+ adafinal_Called : Boolean := False;
+ -- Used to prevent recursive call to adafinal in the event that
+ -- adafinal processing itself raises an unhandled exception.
+
+ type FILEs is new System.Address;
+ type int is new Integer;
+
+ procedure Unhandled_Exception_Terminate is
+ Excep : constant EOA := Get_Current_Excep.all;
+ Msg : constant String := Exception_Message (Excep.all);
+
+ -- Start of processing for Unhandled_Exception_Terminate
+
+ begin
+ -- First call adafinal
+
+ if not adafinal_Called then
+ adafinal_Called := True;
+ System.Soft_Links.Adafinal.all;
+ end if;
+
+ -- Check for special case of raising _ABORT_SIGNAL, which is not
+ -- really an exception at all. We recognize this by the fact that
+ -- it is the only exception whose name starts with underscore.
+
+ if Exception_Name (Excep.all) (1) = '_' then
+ To_Stderr (Nline);
+ To_Stderr ("Execution terminated by abort of environment task");
+ To_Stderr (Nline);
+
+ -- If no tracebacks, we print the unhandled exception in the old style
+ -- (i.e. the style used before ZCX was implemented). We do this to
+ -- retain compatibility, especially with the nightly scripts, but
+ -- this can be removed at some point ???
+
+ elsif Excep.Num_Tracebacks = 0 then
+ To_Stderr (Nline);
+ To_Stderr ("raised ");
+ To_Stderr (Exception_Name (Excep.all));
+
+ if Msg'Length /= 0 then
+ To_Stderr (" : ");
+ To_Stderr (Msg);
+ end if;
+
+ To_Stderr (Nline);
+
+ -- New style, zero cost exception case
+
+ else
+ -- Tailored_Exception_Information is also called here so that the
+ -- backtrace decorator gets called if it has been set. This is
+ -- currently required because some paths in Raise_Current_Excep
+ -- do not go through the calls that display this information.
+ --
+ -- Note also that with the current scheme in Raise_Current_Excep
+ -- we can have this whole information output twice, typically when
+ -- some handler is found on the call chain but none deals with the
+ -- occurrence or if this occurrence gets reraised up to here.
+
+ To_Stderr (Nline);
+ To_Stderr ("Execution terminated by unhandled exception");
+ To_Stderr (Nline);
+ To_Stderr (Tailored_Exception_Information (Excep.all));
+ end if;
+
+ -- Perform system dependent shutdown code
+
+ declare
+ procedure Unhandled_Terminate;
+ pragma No_Return (Unhandled_Terminate);
+ pragma Import
+ (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
+
+ begin
+ Unhandled_Terminate;
+ end;
+
+ end Unhandled_Exception_Terminate;
+
+ ------------------------------
+ -- Raise_Exception_No_Defer --
+ ------------------------------
+
+ procedure Raise_Exception_No_Defer
+ (E : Exception_Id;
+ Message : String := "")
+ is
+ Len : constant Natural :=
+ Natural'Min (Message'Length, Exception_Msg_Max_Length);
+
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Excep.Exception_Raised := False;
+ Excep.Msg_Length := Len;
+ Excep.Msg (1 .. Len) := Message (1 .. Len);
+ Excep.Id := E;
+ Excep.Num_Tracebacks := 0;
+ Excep.Cleanup_Flag := False;
+ Excep.Pid := Local_Partition_ID;
+
+ -- DO NOT CALL Abort_Defer.all; !!!!
+
+ Raise_Current_Excep (E);
+ end Raise_Exception_No_Defer;
+
+ ---------------
+ -- To_Stderr --
+ ---------------
+
+ procedure To_Stderr (S : String) is
+ procedure put_char_stderr (C : int);
+ pragma Import (C, put_char_stderr, "put_char_stderr");
+
+ begin
+ for J in 1 .. S'Length loop
+ if S (J) /= ASCII.CR then
+ put_char_stderr (Character'Pos (S (J)));
+ end if;
+ end loop;
+ end To_Stderr;
+
+ ---------
+ -- ZZZ --
+ ---------
+
+ -- This dummy procedure gives us the end of the PC range for addresses
+ -- within the exception unit itself. We hope that gigi/gcc keeps all the
+ -- procedures in their original order!
+
+ procedure ZZZ is
+ begin
+ null;
+ end ZZZ;
+
+begin
+ -- Allocate the Non-Tasking Machine_State
+
+ Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
+end Ada.Exceptions;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.44 $
+-- --
+-- 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 body is specifically for using an Ada interface to C math.h to get
+-- the computation engine. Many special cases are handled locally to avoid
+-- unnecessary calls. This is not a "strict" implementation, but takes full
+-- advantage of the C functions, e.g. in providing interface to hardware
+-- provided versions of the elementary functions.
+
+-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan,
+-- sinh, cosh, tanh from C library via math.h
+
+with Ada.Numerics.Aux;
+
+package body Ada.Numerics.Generic_Elementary_Functions is
+
+ use type Ada.Numerics.Aux.Double;
+
+ Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
+ Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
+ Half_Log_Two : constant := Log_Two / 2;
+
+
+ subtype T is Float_Type'Base;
+ subtype Double is Aux.Double;
+
+
+ Two_Pi : constant T := 2.0 * Pi;
+ Half_Pi : constant T := Pi / 2.0;
+ Fourth_Pi : constant T := Pi / 4.0;
+
+ Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa);
+ IEpsilon : constant T := 2.0 ** (T'Model_Mantissa - 1);
+ Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Log_Two;
+ Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two;
+ Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two;
+ Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa);
+
+
+ DEpsilon : constant Double := Double (Epsilon);
+ DIEpsilon : constant Double := Double (IEpsilon);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Exp_Strict (X : Float_Type'Base) return Float_Type'Base;
+ -- Cody/Waite routine, supposedly more precise than the library
+ -- version. Currently only needed for Sinh/Cosh on X86 with the largest
+ -- FP type.
+
+ function Local_Atan
+ (Y : Float_Type'Base;
+ X : Float_Type'Base := 1.0)
+ return Float_Type'Base;
+ -- Common code for arc tangent after cyele reduction
+
+ ----------
+ -- "**" --
+ ----------
+
+ function "**" (Left, Right : Float_Type'Base) return Float_Type'Base is
+ A_Right : Float_Type'Base;
+ Int_Part : Integer;
+ Result : Float_Type'Base;
+ R1 : Float_Type'Base;
+ Rest : Float_Type'Base;
+
+ begin
+ if Left = 0.0
+ and then Right = 0.0
+ then
+ raise Argument_Error;
+
+ elsif Left < 0.0 then
+ raise Argument_Error;
+
+ elsif Right = 0.0 then
+ return 1.0;
+
+ elsif Left = 0.0 then
+ if Right < 0.0 then
+ raise Constraint_Error;
+ else
+ return 0.0;
+ end if;
+
+ elsif Left = 1.0 then
+ return 1.0;
+
+ elsif Right = 1.0 then
+ return Left;
+
+ else
+ begin
+ if Right = 2.0 then
+ return Left * Left;
+
+ elsif Right = 0.5 then
+ return Sqrt (Left);
+
+ else
+ A_Right := abs (Right);
+
+ -- If exponent is larger than one, compute integer exponen-
+ -- tiation if possible, and evaluate fractional part with
+ -- more precision. The relative error is now proportional
+ -- to the fractional part of the exponent only.
+
+ if A_Right > 1.0
+ and then A_Right < Float_Type'Base (Integer'Last)
+ then
+ Int_Part := Integer (Float_Type'Base'Truncation (A_Right));
+ Result := Left ** Int_Part;
+ Rest := A_Right - Float_Type'Base (Int_Part);
+
+ -- Compute with two leading bits of the mantissa using
+ -- square roots. Bound to be better than logarithms, and
+ -- easily extended to greater precision.
+
+ if Rest >= 0.5 then
+ R1 := Sqrt (Left);
+ Result := Result * R1;
+ Rest := Rest - 0.5;
+
+ if Rest >= 0.25 then
+ Result := Result * Sqrt (R1);
+ Rest := Rest - 0.25;
+ end if;
+
+ elsif Rest >= 0.25 then
+ Result := Result * Sqrt (Sqrt (Left));
+ Rest := Rest - 0.25;
+ end if;
+
+ Result := Result *
+ Float_Type'Base (Aux.Pow (Double (Left), Double (Rest)));
+
+ if Right >= 0.0 then
+ return Result;
+ else
+ return (1.0 / Result);
+ end if;
+ else
+ return
+ Float_Type'Base (Aux.Pow (Double (Left), Double (Right)));
+ end if;
+ end if;
+
+ exception
+ when others =>
+ raise Constraint_Error;
+ end;
+ end if;
+ end "**";
+
+ ------------
+ -- Arccos --
+ ------------
+
+ -- Natural cycle
+
+ function Arccos (X : Float_Type'Base) return Float_Type'Base is
+ Temp : Float_Type'Base;
+
+ begin
+ if abs X > 1.0 then
+ raise Argument_Error;
+
+ elsif abs X < Sqrt_Epsilon then
+ return Pi / 2.0 - X;
+
+ elsif X = 1.0 then
+ return 0.0;
+
+ elsif X = -1.0 then
+ return Pi;
+ end if;
+
+ Temp := Float_Type'Base (Aux.Acos (Double (X)));
+
+ if Temp < 0.0 then
+ Temp := Pi + Temp;
+ end if;
+
+ return Temp;
+ end Arccos;
+
+ -- Arbitrary cycle
+
+ function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ Temp : Float_Type'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif abs X > 1.0 then
+ raise Argument_Error;
+
+ elsif abs X < Sqrt_Epsilon then
+ return Cycle / 4.0;
+
+ elsif X = 1.0 then
+ return 0.0;
+
+ elsif X = -1.0 then
+ return Cycle / 2.0;
+ end if;
+
+ Temp := Arctan (Sqrt ((1.0 - X) * (1.0 + X)) / X, 1.0, Cycle);
+
+ if Temp < 0.0 then
+ Temp := Cycle / 2.0 + Temp;
+ end if;
+
+ return Temp;
+ end Arccos;
+
+ -------------
+ -- Arccosh --
+ -------------
+
+ function Arccosh (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or
+ -- the proper approximation for X close to 1 or >> 1.
+
+ if X < 1.0 then
+ raise Argument_Error;
+
+ elsif X < 1.0 + Sqrt_Epsilon then
+ return Sqrt (2.0 * (X - 1.0));
+
+ elsif X > 1.0 / Sqrt_Epsilon then
+ return Log (X) + Log_Two;
+
+ else
+ return Log (X + Sqrt ((X - 1.0) * (X + 1.0)));
+ end if;
+ end Arccosh;
+
+ ------------
+ -- Arccot --
+ ------------
+
+ -- Natural cycle
+
+ function Arccot
+ (X : Float_Type'Base;
+ Y : Float_Type'Base := 1.0)
+ return Float_Type'Base
+ is
+ begin
+ -- Just reverse arguments
+
+ return Arctan (Y, X);
+ end Arccot;
+
+ -- Arbitrary cycle
+
+ function Arccot
+ (X : Float_Type'Base;
+ Y : Float_Type'Base := 1.0;
+ Cycle : Float_Type'Base)
+ return Float_Type'Base
+ is
+ begin
+ -- Just reverse arguments
+
+ return Arctan (Y, X, Cycle);
+ end Arccot;
+
+ -------------
+ -- Arccoth --
+ -------------
+
+ function Arccoth (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if abs X > 2.0 then
+ return Arctanh (1.0 / X);
+
+ elsif abs X = 1.0 then
+ raise Constraint_Error;
+
+ elsif abs X < 1.0 then
+ raise Argument_Error;
+
+ else
+ -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the
+ -- other has error 0 or Epsilon.
+
+ return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0)));
+ end if;
+ end Arccoth;
+
+ ------------
+ -- Arcsin --
+ ------------
+
+ -- Natural cycle
+
+ function Arcsin (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if abs X > 1.0 then
+ raise Argument_Error;
+
+ elsif abs X < Sqrt_Epsilon then
+ return X;
+
+ elsif X = 1.0 then
+ return Pi / 2.0;
+
+ elsif X = -1.0 then
+ return -Pi / 2.0;
+ end if;
+
+ return Float_Type'Base (Aux.Asin (Double (X)));
+ end Arcsin;
+
+ -- Arbitrary cycle
+
+ function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif abs X > 1.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0 then
+ return X;
+
+ elsif X = 1.0 then
+ return Cycle / 4.0;
+
+ elsif X = -1.0 then
+ return -Cycle / 4.0;
+ end if;
+
+ return Arctan (X / Sqrt ((1.0 - X) * (1.0 + X)), 1.0, Cycle);
+ end Arcsin;
+
+ -------------
+ -- Arcsinh --
+ -------------
+
+ function Arcsinh (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if abs X < Sqrt_Epsilon then
+ return X;
+
+ elsif X > 1.0 / Sqrt_Epsilon then
+ return Log (X) + Log_Two;
+
+ elsif X < -1.0 / Sqrt_Epsilon then
+ return -(Log (-X) + Log_Two);
+
+ elsif X < 0.0 then
+ return -Log (abs X + Sqrt (X * X + 1.0));
+
+ else
+ return Log (X + Sqrt (X * X + 1.0));
+ end if;
+ end Arcsinh;
+
+ ------------
+ -- Arctan --
+ ------------
+
+ -- Natural cycle
+
+ function Arctan
+ (Y : Float_Type'Base;
+ X : Float_Type'Base := 1.0)
+ return Float_Type'Base
+ is
+ begin
+ if X = 0.0
+ and then Y = 0.0
+ then
+ raise Argument_Error;
+
+ elsif Y = 0.0 then
+ if X > 0.0 then
+ return 0.0;
+ else -- X < 0.0
+ return Pi * Float_Type'Copy_Sign (1.0, Y);
+ end if;
+
+ elsif X = 0.0 then
+ if Y > 0.0 then
+ return Half_Pi;
+ else -- Y < 0.0
+ return -Half_Pi;
+ end if;
+
+ else
+ return Local_Atan (Y, X);
+ end if;
+ end Arctan;
+
+ -- Arbitrary cycle
+
+ function Arctan
+ (Y : Float_Type'Base;
+ X : Float_Type'Base := 1.0;
+ Cycle : Float_Type'Base)
+ return Float_Type'Base
+ is
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0
+ and then Y = 0.0
+ then
+ raise Argument_Error;
+
+ elsif Y = 0.0 then
+ if X > 0.0 then
+ return 0.0;
+ else -- X < 0.0
+ return Cycle / 2.0 * Float_Type'Copy_Sign (1.0, Y);
+ end if;
+
+ elsif X = 0.0 then
+ if Y > 0.0 then
+ return Cycle / 4.0;
+ else -- Y < 0.0
+ return -Cycle / 4.0;
+ end if;
+
+ else
+ return Local_Atan (Y, X) * Cycle / Two_Pi;
+ end if;
+ end Arctan;
+
+ -------------
+ -- Arctanh --
+ -------------
+
+ function Arctanh (X : Float_Type'Base) return Float_Type'Base is
+ A, B, D, A_Plus_1, A_From_1 : Float_Type'Base;
+ Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa;
+
+ begin
+ -- The naive formula:
+
+ -- Arctanh (X) := (1/2) * Log (1 + X) / (1 - X)
+
+ -- is not well-behaved numerically when X < 0.5 and when X is close
+ -- to one. The following is accurate but probably not optimal.
+
+ if abs X = 1.0 then
+ raise Constraint_Error;
+
+ elsif abs X >= 1.0 - 2.0 ** (-Mantissa) then
+
+ if abs X >= 1.0 then
+ raise Argument_Error;
+ else
+
+ -- The one case that overflows if put through the method below:
+ -- abs X = 1.0 - Epsilon. In this case (1/2) log (2/Epsilon) is
+ -- accurate. This simplifies to:
+
+ return Float_Type'Copy_Sign (
+ Half_Log_Two * Float_Type'Base (Mantissa + 1), X);
+ end if;
+
+ -- elsif abs X <= 0.5 then
+ -- why is above line commented out ???
+
+ else
+ -- Use several piecewise linear approximations.
+ -- A is close to X, chosen so 1.0 + A, 1.0 - A, and X - A are exact.
+ -- The two scalings remove the low-order bits of X.
+
+ A := Float_Type'Base'Scaling (
+ Float_Type'Base (Long_Long_Integer
+ (Float_Type'Base'Scaling (X, Mantissa - 1))), 1 - Mantissa);
+
+ B := X - A; -- This is exact; abs B <= 2**(-Mantissa).
+ A_Plus_1 := 1.0 + A; -- This is exact.
+ A_From_1 := 1.0 - A; -- Ditto.
+ D := A_Plus_1 * A_From_1; -- 1 - A*A.
+
+ -- use one term of the series expansion:
+ -- f (x + e) = f(x) + e * f'(x) + ..
+
+ -- The derivative of Arctanh at A is 1/(1-A*A). Next term is
+ -- A*(B/D)**2 (if a quadratic approximation is ever needed).
+
+ return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D;
+
+ -- else
+ -- return 0.5 * Log ((X + 1.0) / (1.0 - X));
+ -- why are above lines commented out ???
+ end if;
+ end Arctanh;
+
+ ---------
+ -- Cos --
+ ---------
+
+ -- Natural cycle
+
+ function Cos (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X = 0.0 then
+ return 1.0;
+
+ elsif abs X < Sqrt_Epsilon then
+ return 1.0;
+
+ end if;
+
+ return Float_Type'Base (Aux.Cos (Double (X)));
+ end Cos;
+
+ -- Arbitrary cycle
+
+ function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ begin
+ -- Just reuse the code for Sin. The potential small
+ -- loss of speed is negligible with proper (front-end) inlining.
+
+ -- ??? Add pragma Inline_Always in spec when this is supported
+ return -Sin (abs X - Cycle * 0.25, Cycle);
+ end Cos;
+
+ ----------
+ -- Cosh --
+ ----------
+
+ function Cosh (X : Float_Type'Base) return Float_Type'Base is
+ Lnv : constant Float_Type'Base := 8#0.542714#;
+ V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
+ Y : Float_Type'Base := abs X;
+ Z : Float_Type'Base;
+
+ begin
+ if Y < Sqrt_Epsilon then
+ return 1.0;
+
+ elsif Y > Log_Inverse_Epsilon then
+ Z := Exp_Strict (Y - Lnv);
+ return (Z + V2minus1 * Z);
+
+ else
+ Z := Exp_Strict (Y);
+ return 0.5 * (Z + 1.0 / Z);
+ end if;
+
+ end Cosh;
+
+ ---------
+ -- Cot --
+ ---------
+
+ -- Natural cycle
+
+ function Cot (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X = 0.0 then
+ raise Constraint_Error;
+
+ elsif abs X < Sqrt_Epsilon then
+ return 1.0 / X;
+ end if;
+
+ return 1.0 / Float_Type'Base (Aux.Tan (Double (X)));
+ end Cot;
+
+ -- Arbitrary cycle
+
+ function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ T : Float_Type'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+ end if;
+
+ T := Float_Type'Base'Remainder (X, Cycle);
+
+ if T = 0.0 or abs T = 0.5 * Cycle then
+ raise Constraint_Error;
+
+ elsif abs T < Sqrt_Epsilon then
+ return 1.0 / T;
+
+ elsif abs T = 0.25 * Cycle then
+ return 0.0;
+
+ else
+ T := T / Cycle * Two_Pi;
+ return Cos (T) / Sin (T);
+ end if;
+ end Cot;
+
+ ----------
+ -- Coth --
+ ----------
+
+ function Coth (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X = 0.0 then
+ raise Constraint_Error;
+
+ elsif X < Half_Log_Epsilon then
+ return -1.0;
+
+ elsif X > -Half_Log_Epsilon then
+ return 1.0;
+
+ elsif abs X < Sqrt_Epsilon then
+ return 1.0 / X;
+ end if;
+
+ return 1.0 / Float_Type'Base (Aux.Tanh (Double (X)));
+ end Coth;
+
+ ---------
+ -- Exp --
+ ---------
+
+ function Exp (X : Float_Type'Base) return Float_Type'Base is
+ Result : Float_Type'Base;
+
+ begin
+ if X = 0.0 then
+ return 1.0;
+ end if;
+
+ Result := Float_Type'Base (Aux.Exp (Double (X)));
+
+ -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows
+ -- is False, then we can just leave it as an infinity (and indeed we
+ -- prefer to do so). But if Machine_Overflows is True, then we have
+ -- to raise a Constraint_Error exception as required by the RM.
+
+ if Float_Type'Machine_Overflows and then not Result'Valid then
+ raise Constraint_Error;
+ end if;
+
+ return Result;
+ end Exp;
+
+ ----------------
+ -- Exp_Strict --
+ ----------------
+
+ function Exp_Strict (X : Float_Type'Base) return Float_Type'Base is
+ G : Float_Type'Base;
+ Z : Float_Type'Base;
+
+ P0 : constant := 0.25000_00000_00000_00000;
+ P1 : constant := 0.75753_18015_94227_76666E-2;
+ P2 : constant := 0.31555_19276_56846_46356E-4;
+
+ Q0 : constant := 0.5;
+ Q1 : constant := 0.56817_30269_85512_21787E-1;
+ Q2 : constant := 0.63121_89437_43985_02557E-3;
+ Q3 : constant := 0.75104_02839_98700_46114E-6;
+
+ C1 : constant := 8#0.543#;
+ C2 : constant := -2.1219_44400_54690_58277E-4;
+ Le : constant := 1.4426_95040_88896_34074;
+
+ XN : Float_Type'Base;
+ P, Q, R : Float_Type'Base;
+
+ begin
+ if X = 0.0 then
+ return 1.0;
+ end if;
+
+ XN := Float_Type'Base'Rounding (X * Le);
+ G := (X - XN * C1) - XN * C2;
+ Z := G * G;
+ P := G * ((P2 * Z + P1) * Z + P0);
+ Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0;
+ R := 0.5 + P / (Q - P);
+
+
+ R := Float_Type'Base'Scaling (R, Integer (XN) + 1);
+
+ -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows
+ -- is False, then we can just leave it as an infinity (and indeed we
+ -- prefer to do so). But if Machine_Overflows is True, then we have
+ -- to raise a Constraint_Error exception as required by the RM.
+
+ if Float_Type'Machine_Overflows and then not R'Valid then
+ raise Constraint_Error;
+ else
+ return R;
+ end if;
+
+ end Exp_Strict;
+
+
+ ----------------
+ -- Local_Atan --
+ ----------------
+
+ function Local_Atan
+ (Y : Float_Type'Base;
+ X : Float_Type'Base := 1.0)
+ return Float_Type'Base
+ is
+ Z : Float_Type'Base;
+ Raw_Atan : Float_Type'Base;
+
+ begin
+ if abs Y > abs X then
+ Z := abs (X / Y);
+ else
+ Z := abs (Y / X);
+ end if;
+
+ if Z < Sqrt_Epsilon then
+ Raw_Atan := Z;
+
+ elsif Z = 1.0 then
+ Raw_Atan := Pi / 4.0;
+
+ else
+ Raw_Atan := Float_Type'Base (Aux.Atan (Double (Z)));
+ end if;
+
+ if abs Y > abs X then
+ Raw_Atan := Half_Pi - Raw_Atan;
+ end if;
+
+ if X > 0.0 then
+ if Y > 0.0 then
+ return Raw_Atan;
+ else -- Y < 0.0
+ return -Raw_Atan;
+ end if;
+
+ else -- X < 0.0
+ if Y > 0.0 then
+ return Pi - Raw_Atan;
+ else -- Y < 0.0
+ return -(Pi - Raw_Atan);
+ end if;
+ end if;
+ end Local_Atan;
+
+ ---------
+ -- Log --
+ ---------
+
+ -- Natural base
+
+ function Log (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X < 0.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0 then
+ raise Constraint_Error;
+
+ elsif X = 1.0 then
+ return 0.0;
+ end if;
+
+ return Float_Type'Base (Aux.Log (Double (X)));
+ end Log;
+
+ -- Arbitrary base
+
+ function Log (X, Base : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X < 0.0 then
+ raise Argument_Error;
+
+ elsif Base <= 0.0 or else Base = 1.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0 then
+ raise Constraint_Error;
+
+ elsif X = 1.0 then
+ return 0.0;
+ end if;
+
+ return Float_Type'Base (Aux.Log (Double (X)) / Aux.Log (Double (Base)));
+ end Log;
+
+ ---------
+ -- Sin --
+ ---------
+
+ -- Natural cycle
+
+ function Sin (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if abs X < Sqrt_Epsilon then
+ return X;
+ end if;
+
+ return Float_Type'Base (Aux.Sin (Double (X)));
+ end Sin;
+
+ -- Arbitrary cycle
+
+ function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ T : Float_Type'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0 then
+ -- Is this test really needed on any machine ???
+ return X;
+ end if;
+
+ T := Float_Type'Base'Remainder (X, Cycle);
+
+ -- The following two reductions reduce the argument
+ -- to the interval [-0.25 * Cycle, 0.25 * Cycle].
+ -- This reduction is exact and is needed to prevent
+ -- inaccuracy that may result if the sinus function
+ -- a different (more accurate) value of Pi in its
+ -- reduction than is used in the multiplication with Two_Pi.
+
+ if abs T > 0.25 * Cycle then
+ T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T;
+ end if;
+
+ -- Could test for 12.0 * abs T = Cycle, and return
+ -- an exact value in those cases. It is not clear that
+ -- this is worth the extra test though.
+
+ return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi)));
+ end Sin;
+
+ ----------
+ -- Sinh --
+ ----------
+
+ function Sinh (X : Float_Type'Base) return Float_Type'Base is
+ Lnv : constant Float_Type'Base := 8#0.542714#;
+ V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
+ Y : Float_Type'Base := abs X;
+ F : constant Float_Type'Base := Y * Y;
+ Z : Float_Type'Base;
+
+ Float_Digits_1_6 : constant Boolean := Float_Type'Digits < 7;
+
+ begin
+ if Y < Sqrt_Epsilon then
+ return X;
+
+ elsif Y > Log_Inverse_Epsilon then
+ Z := Exp_Strict (Y - Lnv);
+ Z := Z + V2minus1 * Z;
+
+ elsif Y < 1.0 then
+
+ if Float_Digits_1_6 then
+
+ -- Use expansion provided by Cody and Waite, p. 226. Note that
+ -- leading term of the polynomial in Q is exactly 1.0.
+
+ declare
+ P0 : constant := -0.71379_3159E+1;
+ P1 : constant := -0.19033_3399E+0;
+ Q0 : constant := -0.42827_7109E+2;
+
+ begin
+ Z := Y + Y * F * (P1 * F + P0) / (F + Q0);
+ end;
+
+ else
+ declare
+ P0 : constant := -0.35181_28343_01771_17881E+6;
+ P1 : constant := -0.11563_52119_68517_68270E+5;
+ P2 : constant := -0.16375_79820_26307_51372E+3;
+ P3 : constant := -0.78966_12741_73570_99479E+0;
+ Q0 : constant := -0.21108_77005_81062_71242E+7;
+ Q1 : constant := 0.36162_72310_94218_36460E+5;
+ Q2 : constant := -0.27773_52311_96507_01667E+3;
+
+ begin
+ Z := Y + Y * F * (((P3 * F + P2) * F + P1) * F + P0)
+ / (((F + Q2) * F + Q1) * F + Q0);
+ end;
+ end if;
+
+ else
+ Z := Exp_Strict (Y);
+ Z := 0.5 * (Z - 1.0 / Z);
+ end if;
+
+ if X > 0.0 then
+ return Z;
+ else
+ return -Z;
+ end if;
+ end Sinh;
+
+ ----------
+ -- Sqrt --
+ ----------
+
+ function Sqrt (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if X < 0.0 then
+ raise Argument_Error;
+
+ -- Special case Sqrt (0.0) to preserve possible minus sign per IEEE
+
+ elsif X = 0.0 then
+ return X;
+
+ end if;
+
+ return Float_Type'Base (Aux.Sqrt (Double (X)));
+ end Sqrt;
+
+ ---------
+ -- Tan --
+ ---------
+
+ -- Natural cycle
+
+ function Tan (X : Float_Type'Base) return Float_Type'Base is
+ begin
+ if abs X < Sqrt_Epsilon then
+ return X;
+
+ elsif abs X = Pi / 2.0 then
+ raise Constraint_Error;
+ end if;
+
+ return Float_Type'Base (Aux.Tan (Double (X)));
+ end Tan;
+
+ -- Arbitrary cycle
+
+ function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is
+ T : Float_Type'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif X = 0.0 then
+ return X;
+ end if;
+
+ T := Float_Type'Base'Remainder (X, Cycle);
+
+ if abs T = 0.25 * Cycle then
+ raise Constraint_Error;
+
+ elsif abs T = 0.5 * Cycle then
+ return 0.0;
+
+ else
+ T := T / Cycle * Two_Pi;
+ return Sin (T) / Cos (T);
+ end if;
+
+ end Tan;
+
+ ----------
+ -- Tanh --
+ ----------
+
+ function Tanh (X : Float_Type'Base) return Float_Type'Base is
+ P0 : constant Float_Type'Base := -0.16134_11902E4;
+ P1 : constant Float_Type'Base := -0.99225_92967E2;
+ P2 : constant Float_Type'Base := -0.96437_49299E0;
+
+ Q0 : constant Float_Type'Base := 0.48402_35707E4;
+ Q1 : constant Float_Type'Base := 0.22337_72071E4;
+ Q2 : constant Float_Type'Base := 0.11274_47438E3;
+ Q3 : constant Float_Type'Base := 0.10000000000E1;
+
+ Half_Ln3 : constant Float_Type'Base := 0.54930_61443;
+
+ P, Q, R : Float_Type'Base;
+ Y : Float_Type'Base := abs X;
+ G : Float_Type'Base := Y * Y;
+
+ Float_Type_Digits_15_Or_More : constant Boolean :=
+ Float_Type'Digits > 14;
+
+ begin
+ if X < Half_Log_Epsilon then
+ return -1.0;
+
+ elsif X > -Half_Log_Epsilon then
+ return 1.0;
+
+ elsif Y < Sqrt_Epsilon then
+ return X;
+
+ elsif Y < Half_Ln3
+ and then Float_Type_Digits_15_Or_More
+ then
+ P := (P2 * G + P1) * G + P0;
+ Q := ((Q3 * G + Q2) * G + Q1) * G + Q0;
+ R := G * (P / Q);
+ return X + X * R;
+
+ else
+ return Float_Type'Base (Aux.Tanh (Double (X)));
+ end if;
+ end Tanh;
+
+end Ada.Numerics.Generic_Elementary_Functions;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+-------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.22 $
+-- --
+-- 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.Strings.Maps; use Ada.Strings.Maps;
+with Ada.Strings.Search;
+
+package body Ada.Strings.Bounded is
+
+ package body Generic_Bounded_Length is
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : in Bounded_String;
+ Right : in Bounded_String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+
+ Nlen : constant Natural := Llen + Right'Length;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+ end if;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left'Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Bounded_String;
+ Right : in Character)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+
+ begin
+ if Llen = Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Result.Length) := Right;
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Character;
+ Right : in Bounded_String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Rlen : Length_Range := Right.Length;
+
+ begin
+ if Rlen = Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Character)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+
+ begin
+ if Left > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Left;
+
+ for J in 1 .. Left loop
+ Result.Data (J) := Right;
+ end loop;
+ end if;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Index_Error;
+ else
+ Result.Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) := Right;
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in Bounded_String)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Pos : Positive := 1;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) :=
+ Right.Data (1 .. Rlen);
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : in Bounded_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length);
+ end "<";
+
+ function "<"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) < Right;
+ end "<";
+
+ function "<"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Data (1 .. Right.Length);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<=" (Left, Right : in Bounded_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length);
+ end "<=";
+
+ function "<="
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Data (1 .. Right.Length);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : in Bounded_String) return Boolean is
+ begin
+ return Left.Length = Right.Length
+ and then Left.Data (1 .. Left.Length) =
+ Right.Data (1 .. Right.Length);
+ end "=";
+
+ function "=" (Left : in Bounded_String; Right : in String)
+ return Boolean is
+ begin
+ return Left.Length = Right'Length
+ and then Left.Data (1 .. Left.Length) = Right;
+ end "=";
+
+ function "=" (Left : in String; Right : in Bounded_String)
+ return Boolean is
+ begin
+ return Left'Length = Right.Length
+ and then Left = Right.Data (1 .. Right.Length);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : in Bounded_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length);
+ end ">";
+
+ function ">"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) > Right;
+ end ">";
+
+ function ">"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Data (1 .. Right.Length);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">=" (Left, Right : in Bounded_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length);
+ end ">=";
+
+ function ">="
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Data (1 .. Right.Length);
+ end ">=";
+
+ ------------
+ -- Append --
+ ------------
+
+ -- Case of Bounded_String and Bounded_String
+
+ function Append
+ (Left, Right : in Bounded_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in Bounded_String;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+ Rlen : constant Length_Range := New_Item.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Source.Data := New_Item.Data;
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of Bounded_String and String
+
+ function Append
+ (Left : in Bounded_String;
+ Right : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right (Right'First .. Right'First - 1 +
+ Max_Length - Llen);
+
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right (Right'Last - (Max_Length - 1) .. Right'Last);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+ Rlen : constant Length_Range := New_Item'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item;
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item (New_Item'First ..
+ New_Item'First - 1 + Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - (Max_Length - 1) ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of String and Bounded_String
+
+ function Append
+ (Left : in String;
+ Right : in Bounded_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left'Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Left (Left'First .. Left'First + (Max_Length - 1));
+
+ else
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right.Data (Rlen - (Max_Length - 1) .. Rlen);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ -- Case of Bounded_String and Character
+
+ function Append
+ (Left : in Bounded_String;
+ Right : in Character;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Llen : constant Length_Range := Left.Length;
+
+ begin
+ if Llen < Max_Length then
+ Result.Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1) := Right;
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ return Left;
+
+ when Strings.Left =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length - 1) :=
+ Left.Data (2 .. Max_Length);
+ Result.Data (Max_Length) := Right;
+ return Result;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in Character;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+
+ begin
+ if Llen < Max_Length then
+ Source.Length := Llen + 1;
+ Source.Data (Llen + 1) := New_Item;
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ null;
+
+ when Strings.Left =>
+ Source.Data (1 .. Max_Length - 1) :=
+ Source.Data (2 .. Max_Length);
+ Source.Data (Max_Length) := New_Item;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of Character and Bounded_String
+
+ function Append
+ (Left : in Character;
+ Right : in Bounded_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Rlen : constant Length_Range := Right.Length;
+
+ begin
+ if Rlen < Max_Length then
+ Result.Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Length := Max_Length;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - 1);
+ return Result;
+
+ when Strings.Left =>
+ return Right;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Append;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set)
+ return Natural
+ is
+ begin
+ return Search.Count (Source.Data (1 .. Source.Length), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : in Bounded_String;
+ From : in Positive;
+ Through : in Natural)
+ return Bounded_String
+ is
+ Slen : constant Natural := Source.Length;
+ Num_Delete : constant Integer := Through - From + 1;
+ Result : Bounded_String;
+
+ begin
+ if Num_Delete <= 0 then
+ return Source;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Result.Length := From - 1;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ return Result;
+
+ else
+ Result.Length := Slen - Num_Delete;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ Result.Data (From .. Result.Length) :=
+ Source.Data (Through + 1 .. Slen);
+ return Result;
+ end if;
+ end Delete;
+
+ procedure Delete
+ (Source : in out Bounded_String;
+ From : in Positive;
+ Through : in Natural)
+ is
+ Slen : constant Natural := Source.Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Source.Length := From - 1;
+
+ else
+ Source.Length := Slen - Num_Delete;
+ Source.Data (From .. Source.Length) :=
+ Source.Data (Through + 1 .. Slen);
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : in Bounded_String;
+ Index : in Positive)
+ return Character
+ is
+ begin
+ if Index in 1 .. Source.Length then
+ return Source.Data (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Element;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Search.Find_Token
+ (Source.Data (1 .. Source.Length), Set, Test, First, Last);
+ end Find_Token;
+
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : in Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Length := Count;
+ Result.Data (1 .. Count) := Source.Data (1 .. Count);
+
+ elsif Count <= Max_Length then
+ Result.Length := Count;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Max_Length - Npad) :=
+ Source.Data (Count - Max_Length + 1 .. Slen);
+ Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
+ (others => Pad);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Head;
+
+ procedure Head
+ (Source : in out Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ is
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : String (1 .. Max_Length);
+
+ begin
+ if Npad <= 0 then
+ Source.Length := Count;
+
+ elsif Count <= Max_Length then
+ Source.Length := Count;
+ Source.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad > Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Temp := Source.Data;
+ Source.Data (1 .. Max_Length - Npad) :=
+ Temp (Count - Max_Length + 1 .. Slen);
+
+ for J in Max_Length - Npad + 1 .. Max_Length loop
+ Source.Data (J) := Pad;
+ end loop;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Going : in Strings.Direction := Strings.Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Strings.Membership := Strings.Inside;
+ Going : in Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Length), Set, Test, Going);
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : in Bounded_String;
+ Going : in Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return
+ Search.Index_Non_Blank (Source.Data (1 .. Source.Length), Going);
+ end Index_Non_Blank;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : in Bounded_String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Slen : constant Natural := Source.Length;
+ Nlen : constant Natural := New_Item'Length;
+ Tlen : constant Natural := Slen + Nlen;
+ Blen : constant Natural := Before - 1;
+ Alen : constant Integer := Slen - Blen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Bounded_String;
+
+ -- Tlen is the length of the total string before possible truncation.
+ -- Blen, Alen are the lengths of the before and after pieces of the
+ -- source string.
+
+ begin
+ if Alen < 0 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Droplen <= 0 then
+ Result.Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Tlen) :=
+ Source.Data (Before .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Before .. Max_Length) :=
+ New_Item (New_Item'First
+ .. New_Item'First + Max_Length - Before);
+ else
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Max_Length) :=
+ Source.Data (Before .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (Before .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ New_Item (New_Item'Last - (Max_Length - Alen) + 1
+ .. New_Item'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) :=
+ New_Item;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Insert;
+
+ procedure Insert
+ (Source : in out Bounded_String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Insert (Source, Before, New_Item, Drop);
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : in Bounded_String) return Length_Range is
+ begin
+ return Source.Length;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : in Bounded_String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Endpos : constant Natural := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif New_Item'Length = 0 then
+ return Source;
+
+ elsif Endpos <= Slen then
+ Result.Length := Source.Length;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ elsif Endpos <= Max_Length then
+ Result.Length := Endpos;
+ Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ else
+ Result.Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Position - 1) :=
+ Source.Data (1 .. Position - 1);
+
+ Result.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+ return Result;
+
+ when Strings.Left =>
+ if New_Item'Length >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+ return Result;
+
+ else
+ Result.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+ Result.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ return Result;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Bounded_String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ Endpos : constant Positive := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Endpos <= Slen then
+ Source.Data (Position .. Endpos) := New_Item;
+
+ elsif Endpos <= Max_Length then
+ Source.Data (Position .. Endpos) := New_Item;
+ Source.Length := Endpos;
+
+ else
+ Source.Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+
+ when Strings.Left =>
+ if New_Item'Length > Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+
+ Source.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Overwrite;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Bounded_String;
+ Index : in Positive;
+ By : in Character)
+ is
+ begin
+ if Index <= Source.Length then
+ Source.Data (Index) := By;
+ else
+ raise Ada.Strings.Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : in Bounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Slen : constant Natural := Source.Length;
+
+ begin
+ if Low > Slen + 1 then
+ raise Strings.Index_Error;
+
+ elsif High < Low then
+ return Insert (Source, Low, By, Drop);
+
+ else
+ declare
+ Blen : constant Natural := Natural'Max (0, Low - 1);
+ Alen : constant Natural := Natural'Max (0, Slen - High);
+ Tlen : constant Natural := Blen + By'Length + Alen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Bounded_String;
+
+ -- Tlen is the total length of the result string before any
+ -- truncation. Blen and Alen are the lengths of the pieces
+ -- of the original string that end up in the result string
+ -- before and after the replaced slice.
+
+ begin
+ if Droplen <= 0 then
+ Result.Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Tlen) :=
+ Source.Data (High + 1 .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Low .. Max_Length) :=
+ By (By'First .. By'First + Max_Length - Low);
+ else
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Max_Length) :=
+ Source.Data (High + 1 .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (High + 1 .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) := By;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Replace_Slice (Source, Low, High, By, Drop);
+ end Replace_Slice;
+
+ ---------------
+ -- Replicate --
+ ---------------
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Character;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+
+ begin
+ if Count <= Max_Length then
+ Result.Length := Count;
+
+ elsif Drop = Strings.Error then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Length := Max_Length;
+ end if;
+
+ Result.Data (1 .. Result.Length) := (others => Item);
+ return Result;
+ end Replicate;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Length : constant Integer := Count * Item'Length;
+ Result : Bounded_String;
+ Indx : Positive;
+
+ begin
+ if Length <= Max_Length then
+ Result.Length := Length;
+
+ if Length > 0 then
+ Indx := 1;
+
+ for J in 1 .. Count loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+ end if;
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Indx := 1;
+
+ while Indx + Item'Length <= Max_Length + 1 loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+
+ Result.Data (Indx .. Max_Length) :=
+ Item (Item'First .. Item'First + Max_Length - Indx);
+
+ when Strings.Left =>
+ Indx := Max_Length;
+
+ while Indx - Item'Length >= 1 loop
+ Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
+ Indx := Indx - Item'Length;
+ end loop;
+
+ Result.Data (1 .. Indx) :=
+ Item (Item'Last - Indx + 1 .. Item'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Replicate;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Bounded_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ begin
+ return Replicate (Count, Item.Data (1 .. Item.Length), Drop);
+ end Replicate;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Bounded_String;
+ Low : Positive;
+ High : Natural)
+ return String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Length + 1 or else High > Source.Length then
+ raise Index_Error;
+ else
+ return Source.Data (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : in Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Length := Count;
+ Result.Data (1 .. Count) :=
+ Source.Data (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Result.Length := Count;
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Max_Length) :=
+ Source.Data (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (1 .. Max_Length - Slen) := (others => Pad);
+ Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Source.Data (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Tail;
+
+ procedure Tail
+ (Source : in out Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ is
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : String (1 .. Max_Length) := Source.Data;
+
+ begin
+ if Npad <= 0 then
+ Source.Length := Count;
+ Source.Data (1 .. Count) :=
+ Temp (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Source.Length := Count;
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Max_Length) :=
+ Temp (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ for J in 1 .. Max_Length - Slen loop
+ Source.Data (J) := Pad;
+ end loop;
+
+ Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Temp (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Tail;
+
+ -----------------------
+ -- To_Bounded_String --
+ -----------------------
+
+ function To_Bounded_String
+ (Source : in String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_String
+ is
+ Slen : constant Natural := Source'Length;
+ Result : Bounded_String;
+
+ begin
+ if Slen <= Max_Length then
+ Result.Length := Slen;
+ Result.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end To_Bounded_String;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Source : in Bounded_String) return String is
+ begin
+ return Source.Data (1 .. Source.Length);
+ end To_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : in Bounded_String;
+ Mapping : in Maps.Character_Mapping)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+
+ begin
+ Result.Length := Source.Length;
+
+ for J in 1 .. Source.Length loop
+ Result.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Bounded_String;
+ Mapping : in Maps.Character_Mapping)
+ is
+ begin
+ for J in 1 .. Source.Length loop
+ Source.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+ end Translate;
+
+ function Translate
+ (Source : in Bounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+
+ begin
+ Result.Length := Source.Length;
+
+ for J in 1 .. Source.Length loop
+ Result.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Bounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ is
+ begin
+ for J in 1 .. Source.Length loop
+ Source.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim (Source : in Bounded_String; Side : in Trim_End)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+ Last : Natural := Source.Length;
+ First : Positive := 1;
+
+ begin
+ if Side = Left or else Side = Both then
+ while First <= Last and then Source.Data (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Source.Data (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Result.Length := Last - First + 1;
+ Result.Data (1 .. Result.Length) := Source.Data (First .. Last);
+ return Result;
+
+ end Trim;
+
+ procedure Trim
+ (Source : in out Bounded_String;
+ Side : in Trim_End)
+ is
+ Last : Length_Range := Source.Length;
+ First : Positive := 1;
+ Temp : String (1 .. Max_Length);
+
+ begin
+ Temp (1 .. Last) := Source.Data (1 .. Last);
+
+ if Side = Left or else Side = Both then
+ while First <= Last and then Temp (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Temp (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Source := Null_Bounded_String;
+ Source.Length := Last - First + 1;
+ Source.Data (1 .. Source.Length) := Temp (First .. Last);
+
+ end Trim;
+
+ function Trim
+ (Source : in Bounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return Bounded_String
+ is
+ Result : Bounded_String;
+
+ begin
+ for First in 1 .. Source.Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ Result.Length := Last - First + 1;
+ Result.Data (1 .. Result.Length) :=
+ Source.Data (First .. Last);
+ return Result;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Result.Length := 0;
+ return Result;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Bounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ is
+ begin
+ for First in 1 .. Source.Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ if First = 1 then
+ Source.Length := Last;
+ return;
+ else
+ Source.Length := Last - First + 1;
+ Source.Data (1 .. Source.Length) :=
+ Source.Data (First .. Last);
+
+ for J in Source.Length + 1 .. Max_Length loop
+ Source.Data (J) := ASCII.NUL;
+ end loop;
+
+ return;
+ end if;
+ end if;
+ end loop;
+
+ Source.Length := 0;
+ return;
+ end if;
+ end loop;
+
+ Source.Length := 0;
+ end Trim;
+
+ end Generic_Bounded_Length;
+
+end Ada.Strings.Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . F I X E D --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: This code is derived from the ADAR.CSH public domain Ada 83
+-- versions of the Appendix C string handling packages. One change is
+-- to avoid the use of Is_In, so that we are not dependent on inlining.
+-- Note that the search function implementations are to be found in the
+-- auxiliary package Ada.Strings.Search. Also the Move procedure is
+-- directly incorporated (ADAR used a subunit for this procedure). A
+-- number of errors having to do with bounds of function return results
+-- were also fixed, and use of & removed for efficiency reasons.
+
+with Ada.Strings.Maps; use Ada.Strings.Maps;
+with Ada.Strings.Search;
+
+package body Ada.Strings.Fixed is
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ renames Ada.Strings.Search.Index;
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Search.Index;
+
+ function Index
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ renames Ada.Strings.Search.Index;
+
+ function Index_Non_Blank
+ (Source : in String;
+ Going : in Direction := Forward)
+ return Natural
+ renames Ada.Strings.Search.Index_Non_Blank;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ renames Ada.Strings.Search.Count;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Search.Count;
+
+ function Count
+ (Source : in String;
+ Set : in Maps.Character_Set)
+ return Natural
+ renames Ada.Strings.Search.Count;
+
+ procedure Find_Token
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Ada.Strings.Search.Find_Token;
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Character)
+ return String
+ is
+ Result : String (1 .. Left);
+
+ begin
+ for J in Result'Range loop
+ Result (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in String)
+ return String
+ is
+ Result : String (1 .. Left * Right'Length);
+ Ptr : Integer := 1;
+
+ begin
+ for J in 1 .. Left loop
+ Result (Ptr .. Ptr + Right'Length - 1) := Right;
+ Ptr := Ptr + Right'Length;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : in String;
+ From : in Positive;
+ Through : in Natural)
+ return String
+ is
+ begin
+ if From > Through then
+ declare
+ subtype Result_Type is String (1 .. Source'Length);
+
+ begin
+ return Result_Type (Source);
+ end;
+
+ elsif From not in Source'Range
+ or else Through > Source'Last
+ then
+ raise Index_Error;
+
+ else
+ declare
+ Front : constant Integer := From - Source'First;
+ Result : String (1 .. Source'Length - (Through - From + 1));
+
+ begin
+ Result (1 .. Front) :=
+ Source (Source'First .. From - 1);
+ Result (Front + 1 .. Result'Last) :=
+ Source (Through + 1 .. Source'Last);
+
+ return Result;
+ end;
+ end if;
+ end Delete;
+
+ procedure Delete
+ (Source : in out String;
+ From : in Positive;
+ Through : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Source => Delete (Source, From, Through),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Delete;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : in String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return String
+ is
+ subtype Result_Type is String (1 .. Count);
+
+ begin
+ if Count < Source'Length then
+ return
+ Result_Type (Source (Source'First .. Source'First + Count - 1));
+
+ else
+ declare
+ Result : Result_Type;
+
+ begin
+ Result (1 .. Source'Length) := Source;
+
+ for J in Source'Length + 1 .. Count loop
+ Result (J) := Pad;
+ end loop;
+
+ return Result;
+ end;
+ end if;
+ end Head;
+
+ procedure Head
+ (Source : in out String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Source => Head (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Head;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : in String;
+ Before : in Positive;
+ New_Item : in String)
+ return String
+ is
+ Result : String (1 .. Source'Length + New_Item'Length);
+ Front : constant Integer := Before - Source'First;
+
+ begin
+ if Before not in Source'First .. Source'Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Result (1 .. Front) :=
+ Source (Source'First .. Before - 1);
+ Result (Front + 1 .. Front + New_Item'Length) :=
+ New_Item;
+ Result (Front + New_Item'Length + 1 .. Result'Last) :=
+ Source (Before .. Source'Last);
+
+ return Result;
+ end Insert;
+
+ procedure Insert
+ (Source : in out String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ is
+ begin
+ Move (Source => Insert (Source, Before, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Insert;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Source : in String;
+ Target : out String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ Sfirst : constant Integer := Source'First;
+ Slast : constant Integer := Source'Last;
+ Slength : constant Integer := Source'Length;
+
+ Tfirst : constant Integer := Target'First;
+ Tlast : constant Integer := Target'Last;
+ Tlength : constant Integer := Target'Length;
+
+ function Is_Padding (Item : String) return Boolean;
+ -- Check if Item is all Pad characters, return True if so, False if not
+
+ function Is_Padding (Item : String) return Boolean is
+ begin
+ for J in Item'Range loop
+ if Item (J) /= Pad then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Padding;
+
+ -- Start of processing for Move
+
+ begin
+ if Slength = Tlength then
+ Target := Source;
+
+ elsif Slength > Tlength then
+
+ case Drop is
+ when Left =>
+ Target := Source (Slast - Tlength + 1 .. Slast);
+
+ when Right =>
+ Target := Source (Sfirst .. Sfirst + Tlength - 1);
+
+ when Error =>
+ case Justify is
+ when Left =>
+ if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
+ Target :=
+ Source (Sfirst .. Sfirst + Target'Length - 1);
+ else
+ raise Length_Error;
+ end if;
+
+ when Right =>
+ if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
+ Target := Source (Slast - Tlength + 1 .. Slast);
+ else
+ raise Length_Error;
+ end if;
+
+ when Center =>
+ raise Length_Error;
+ end case;
+
+ end case;
+
+ -- Source'Length < Target'Length
+
+ else
+ case Justify is
+ when Left =>
+ Target (Tfirst .. Tfirst + Slength - 1) := Source;
+
+ for I in Tfirst + Slength .. Tlast loop
+ Target (I) := Pad;
+ end loop;
+
+ when Right =>
+ for I in Tfirst .. Tlast - Slength loop
+ Target (I) := Pad;
+ end loop;
+
+ Target (Tlast - Slength + 1 .. Tlast) := Source;
+
+ when Center =>
+ declare
+ Front_Pad : constant Integer := (Tlength - Slength) / 2;
+ Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
+
+ begin
+ for I in Tfirst .. Tfirst_Fpad - 1 loop
+ Target (I) := Pad;
+ end loop;
+
+ Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
+
+ for I in Tfirst_Fpad + Slength .. Tlast loop
+ Target (I) := Pad;
+ end loop;
+ end;
+ end case;
+ end if;
+ end Move;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : in String;
+ Position : in Positive;
+ New_Item : in String)
+ return String
+ is
+ begin
+ if Position not in Source'First .. Source'Last + 1 then
+ raise Index_Error;
+ end if;
+
+ declare
+ Result_Length : Natural :=
+ Integer'Max
+ (Source'Length, Position - Source'First + New_Item'Length);
+
+ Result : String (1 .. Result_Length);
+ Front : constant Integer := Position - Source'First;
+
+ begin
+ Result (1 .. Front) :=
+ Source (Source'First .. Position - 1);
+ Result (Front + 1 .. Front + New_Item'Length) :=
+ New_Item;
+ Result (Front + New_Item'Length + 1 .. Result'Length) :=
+ Source (Position + New_Item'Length .. Source'Last);
+ return Result;
+ end;
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Right)
+ is
+ begin
+ Move (Source => Overwrite (Source, Position, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Overwrite;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : in String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String)
+ return String
+ is
+ begin
+ if Low > Source'Last + 1 or High < Source'First - 1 then
+ raise Index_Error;
+ end if;
+
+ if High >= Low then
+ declare
+ Front_Len : constant Integer :=
+ Integer'Max (0, Low - Source'First);
+ -- Length of prefix of Source copied to result
+
+ Back_Len : constant Integer :=
+ Integer'Max (0, Source'Last - High);
+ -- Length of suffix of Source copied to result
+
+ Result_Length : constant Integer :=
+ Front_Len + By'Length + Back_Len;
+ -- Length of result
+
+ Result : String (1 .. Result_Length);
+
+ begin
+ Result (1 .. Front_Len) :=
+ Source (Source'First .. Low - 1);
+ Result (Front_Len + 1 .. Front_Len + By'Length) :=
+ By;
+ Result (Front_Len + By'Length + 1 .. Result'Length) :=
+ Source (High + 1 .. Source'Last);
+
+ return Result;
+ end;
+
+ else
+ return Insert (Source, Before => Low, New_Item => By);
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
+ end Replace_Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : in String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return String
+ is
+ subtype Result_Type is String (1 .. Count);
+
+ begin
+ if Count < Source'Length then
+ return Result_Type (Source (Source'Last - Count + 1 .. Source'Last));
+
+ -- Pad on left
+
+ else
+ declare
+ Result : Result_Type;
+
+ begin
+ for J in 1 .. Count - Source'Length loop
+ Result (J) := Pad;
+ end loop;
+
+ Result (Count - Source'Length + 1 .. Count) := Source;
+ return Result;
+ end;
+ end if;
+ end Tail;
+
+ procedure Tail
+ (Source : in out String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Source => Tail (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Tail;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : in String;
+ Mapping : in Maps.Character_Mapping)
+ return String
+ is
+ Result : String (1 .. Source'Length);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out String;
+ Mapping : in Maps.Character_Mapping)
+ is
+ begin
+ for J in Source'Range loop
+ Source (J) := Value (Mapping, Source (J));
+ end loop;
+ end Translate;
+
+ function Translate
+ (Source : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return String
+ is
+ Result : String (1 .. Source'Length);
+ pragma Unsuppress (Access_Check);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Mapping.all (Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out String;
+ Mapping : in Maps.Character_Mapping_Function)
+ is
+ pragma Unsuppress (Access_Check);
+ begin
+ for J in Source'Range loop
+ Source (J) := Mapping.all (Source (J));
+ end loop;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : in String;
+ Side : in Trim_End)
+ return String
+ is
+ Low, High : Integer;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks case
+
+ if Low = 0 then
+ return "";
+
+ -- At least one non-blank
+
+ else
+ High := Index_Non_Blank (Source, Backward);
+
+ case Side is
+ when Strings.Left =>
+ declare
+ subtype Result_Type is String (1 .. Source'Last - Low + 1);
+
+ begin
+ return Result_Type (Source (Low .. Source'Last));
+ end;
+
+ when Strings.Right =>
+ declare
+ subtype Result_Type is String (1 .. High - Source'First + 1);
+
+ begin
+ return Result_Type (Source (Source'First .. High));
+ end;
+
+ when Strings.Both =>
+ declare
+ subtype Result_Type is String (1 .. High - Low + 1);
+
+ begin
+ return Result_Type (Source (Low .. High));
+ end;
+ end case;
+ end if;
+ end Trim;
+
+ procedure Trim
+ (Source : in out String;
+ Side : in Trim_End;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Trim (Source, Side),
+ Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+ function Trim
+ (Source : in String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return String
+ is
+ High, Low : Integer;
+
+ begin
+ Low := Index (Source, Set => Left, Test => Outside, Going => Forward);
+
+ -- Case where source comprises only characters in Left
+
+ if Low = 0 then
+ return "";
+ end if;
+
+ High :=
+ Index (Source, Set => Right, Test => Outside, Going => Backward);
+
+ -- Case where source comprises only characters in Right
+
+ if High = 0 then
+ return "";
+ end if;
+
+ declare
+ subtype Result_Type is String (1 .. High - Low + 1);
+
+ begin
+ return Result_Type (Source (Low .. High));
+ end;
+ end Trim;
+
+ procedure Trim
+ (Source : in out String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set;
+ Justify : in Alignment := Strings.Left;
+ Pad : in Character := Space)
+ is
+ begin
+ Move (Source => Trim (Source, Left, Right),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+end Ada.Strings.Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . F I X E D --
+-- --
+-- 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.Strings.Maps;
+
+package Ada.Strings.Fixed is
+pragma Preelaborate (Fixed);
+
+ --------------------------------------------------------------
+ -- Copy Procedure for Strings of Possibly Different Lengths --
+ --------------------------------------------------------------
+
+ procedure Move
+ (Source : in String;
+ Target : out String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Set : in Maps.Character_Set)
+ return Natural;
+
+ procedure Find_Token
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : in String;
+ Mapping : in Maps.Character_Mapping)
+ return String;
+
+ procedure Translate
+ (Source : in out String;
+ Mapping : in Maps.Character_Mapping);
+
+ function Translate
+ (Source : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return String;
+
+ procedure Translate
+ (Source : in out String;
+ Mapping : in Maps.Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : in String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String)
+ return String;
+
+ procedure Replace_Slice
+ (Source : in out String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ function Insert
+ (Source : in String;
+ Before : in Positive;
+ New_Item : in String)
+ return String;
+
+ procedure Insert
+ (Source : in out String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error);
+
+ function Overwrite
+ (Source : in String;
+ Position : in Positive;
+ New_Item : in String)
+ return String;
+
+ procedure Overwrite
+ (Source : in out String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Right);
+
+ function Delete
+ (Source : in String;
+ From : in Positive;
+ Through : in Natural)
+ return String;
+
+ procedure Delete
+ (Source : in out String;
+ From : in Positive;
+ Through : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ ---------------------------------
+ -- String Selector Subprograms --
+ ---------------------------------
+
+ function Trim
+ (Source : in String;
+ Side : in Trim_End)
+ return String;
+
+ procedure Trim
+ (Source : in out String;
+ Side : in Trim_End;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ function Trim
+ (Source : in String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return String;
+
+ procedure Trim
+ (Source : in out String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set;
+ Justify : in Alignment := Strings.Left;
+ Pad : in Character := Space);
+
+ function Head
+ (Source : in String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return String;
+
+ procedure Head
+ (Source : in out String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ function Tail
+ (Source : in String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return String;
+
+ procedure Tail
+ (Source : in out String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Character := Space);
+
+ ----------------------------------
+ -- String Constructor Functions --
+ ----------------------------------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Character)
+ return String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in String)
+ return String;
+
+end Ada.Strings.Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G 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.Strings is
+pragma Pure (Strings);
+
+ Space : constant Character := ' ';
+ Wide_Space : constant Wide_Character := ' ';
+
+ Length_Error, Pattern_Error, Index_Error, Translation_Error : exception;
+
+ type Alignment is (Left, Right, Center);
+ type Truncation is (Left, Right, Error);
+ type Membership is (Inside, Outside);
+ type Direction is (Forward, Backward);
+ type Trim_End is (Left, Right, Both);
+
+end Ada.Strings;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . M A P S --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: parts of this code are derived from the ADAR.CSH public domain
+-- Ada 83 versions of the Appendix C string handling packages. The main
+-- differences are that we avoid the use of the minimize function which
+-- is bit-by-bit or character-by-character and therefore rather slow.
+-- Generally for character sets we favor the full 32-byte representation.
+
+package body Ada.Strings.Maps is
+
+ use Ada.Characters.Latin_1;
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (Left, Right : Character_Set) return Character_Set is
+ begin
+ return Left and not Right;
+ end "-";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : in Character_Set) return Boolean is
+ begin
+ return Character_Set_Internal (Left) = Character_Set_Internal (Right);
+ end "=";
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and" (Left, Right : in Character_Set) return Character_Set is
+ begin
+ return Character_Set
+ (Character_Set_Internal (Left) and Character_Set_Internal (Right));
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not" (Right : in Character_Set) return Character_Set is
+ begin
+ return Character_Set (not Character_Set_Internal (Right));
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or" (Left, Right : in Character_Set) return Character_Set is
+ begin
+ return Character_Set
+ (Character_Set_Internal (Left) or Character_Set_Internal (Right));
+ end "or";
+
+ -----------
+ -- "xor" --
+ -----------
+
+ function "xor" (Left, Right : in Character_Set) return Character_Set is
+ begin
+ return Character_Set
+ (Character_Set_Internal (Left) xor Character_Set_Internal (Right));
+ end "xor";
+
+ -----------
+ -- Is_In --
+ -----------
+
+ function Is_In
+ (Element : Character;
+ Set : Character_Set)
+ return Boolean
+ is
+ begin
+ return Set (Element);
+ end Is_In;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Elements : Character_Set;
+ Set : Character_Set)
+ return Boolean
+ is
+ begin
+ return (Elements and Set) = Elements;
+ end Is_Subset;
+
+ ---------------
+ -- To_Domain --
+ ---------------
+
+ function To_Domain (Map : in Character_Mapping) return Character_Sequence
+ is
+ Result : String (1 .. Map'Length);
+ J : Natural;
+
+ begin
+ J := 0;
+ for C in Map'Range loop
+ if Map (C) /= C then
+ J := J + 1;
+ Result (J) := C;
+ end if;
+ end loop;
+
+ return Result (1 .. J);
+ end To_Domain;
+
+ ----------------
+ -- To_Mapping --
+ ----------------
+
+ function To_Mapping
+ (From, To : in Character_Sequence)
+ return Character_Mapping
+ is
+ Result : Character_Mapping;
+ Inserted : Character_Set := Null_Set;
+ From_Len : constant Natural := From'Length;
+ To_Len : constant Natural := To'Length;
+
+ begin
+ if From_Len /= To_Len then
+ raise Strings.Translation_Error;
+ end if;
+
+ for Char in Character loop
+ Result (Char) := Char;
+ end loop;
+
+ for J in From'Range loop
+ if Inserted (From (J)) then
+ raise Strings.Translation_Error;
+ end if;
+
+ Result (From (J)) := To (J - From'First + To'First);
+ Inserted (From (J)) := True;
+ end loop;
+
+ return Result;
+ end To_Mapping;
+
+ --------------
+ -- To_Range --
+ --------------
+
+ function To_Range (Map : in Character_Mapping) return Character_Sequence
+ is
+ Result : String (1 .. Map'Length);
+ J : Natural;
+
+ begin
+ J := 0;
+ for C in Map'Range loop
+ if Map (C) /= C then
+ J := J + 1;
+ Result (J) := Map (C);
+ end if;
+ end loop;
+
+ return Result (1 .. J);
+ end To_Range;
+
+ ---------------
+ -- To_Ranges --
+ ---------------
+
+ function To_Ranges (Set : in Character_Set) return Character_Ranges is
+ Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
+ Range_Num : Natural;
+ C : Character;
+
+ begin
+ C := Character'First;
+ Range_Num := 0;
+
+ loop
+ -- Skip gap between subsets.
+
+ while not Set (C) loop
+ exit when C = Character'Last;
+ C := Character'Succ (C);
+ end loop;
+
+ exit when not Set (C);
+
+ Range_Num := Range_Num + 1;
+ Max_Ranges (Range_Num).Low := C;
+
+ -- Span a subset.
+
+ loop
+ exit when not Set (C) or else C = Character'Last;
+ C := Character' Succ (C);
+ end loop;
+
+ if Set (C) then
+ Max_Ranges (Range_Num). High := C;
+ exit;
+ else
+ Max_Ranges (Range_Num). High := Character'Pred (C);
+ end if;
+ end loop;
+
+ return Max_Ranges (1 .. Range_Num);
+ end To_Ranges;
+
+ -----------------
+ -- To_Sequence --
+ -----------------
+
+ function To_Sequence
+ (Set : Character_Set)
+ return Character_Sequence
+ is
+ Result : String (1 .. Character'Pos (Character'Last) + 1);
+ Count : Natural := 0;
+
+ begin
+ for Char in Set'Range loop
+ if Set (Char) then
+ Count := Count + 1;
+ Result (Count) := Char;
+ end if;
+ end loop;
+
+ return Result (1 .. Count);
+ end To_Sequence;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ function To_Set (Ranges : in Character_Ranges) return Character_Set is
+ Result : Character_Set;
+
+ begin
+ for C in Result'Range loop
+ Result (C) := False;
+ end loop;
+
+ for R in Ranges'Range loop
+ for C in Ranges (R).Low .. Ranges (R).High loop
+ Result (C) := True;
+ end loop;
+ end loop;
+
+ return Result;
+ end To_Set;
+
+ function To_Set (Span : in Character_Range) return Character_Set is
+ Result : Character_Set;
+
+ begin
+ for C in Result'Range loop
+ Result (C) := False;
+ end loop;
+
+ for C in Span.Low .. Span.High loop
+ Result (C) := True;
+ end loop;
+
+ return Result;
+ end To_Set;
+
+ function To_Set (Sequence : Character_Sequence) return Character_Set is
+ Result : Character_Set := Null_Set;
+
+ begin
+ for J in Sequence'Range loop
+ Result (Sequence (J)) := True;
+ end loop;
+
+ return Result;
+ end To_Set;
+
+ function To_Set (Singleton : Character) return Character_Set is
+ Result : Character_Set := Null_Set;
+
+ begin
+ Result (Singleton) := True;
+ return Result;
+ end To_Set;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value (Map : in Character_Mapping; Element : in Character)
+ return Character is
+
+ begin
+ return Map (Element);
+ end Value;
+
+end Ada.Strings.Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . M A P S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.22 $
+-- --
+-- 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 is
+pragma Preelaborate (Maps);
+
+ package L renames Ada.Characters.Latin_1;
+
+ --------------------------------
+ -- Character Set Declarations --
+ --------------------------------
+
+ type Character_Set is private;
+ -- Representation for a set of character values:
+
+ Null_Set : constant Character_Set;
+
+ ---------------------------
+ -- Constructors for Sets --
+ ---------------------------
+
+ type Character_Range is record
+ Low : Character;
+ High : Character;
+ end record;
+ -- Represents Character range Low .. High
+
+ type Character_Ranges is array (Positive range <>) of Character_Range;
+
+ function To_Set (Ranges : in Character_Ranges) return Character_Set;
+
+ function To_Set (Span : in Character_Range) return Character_Set;
+
+ function To_Ranges (Set : in Character_Set) return Character_Ranges;
+
+ ----------------------------------
+ -- Operations on Character Sets --
+ ----------------------------------
+
+ function "=" (Left, Right : in Character_Set) return Boolean;
+
+ function "not" (Right : in Character_Set) return Character_Set;
+ function "and" (Left, Right : in Character_Set) return Character_Set;
+ function "or" (Left, Right : in Character_Set) return Character_Set;
+ function "xor" (Left, Right : in Character_Set) return Character_Set;
+ function "-" (Left, Right : in Character_Set) return Character_Set;
+
+ function Is_In
+ (Element : in Character;
+ Set : in Character_Set)
+ return Boolean;
+
+ function Is_Subset
+ (Elements : in Character_Set;
+ Set : in Character_Set)
+ return Boolean;
+
+ function "<="
+ (Left : in Character_Set;
+ Right : in Character_Set)
+ return Boolean
+ renames Is_Subset;
+
+ subtype Character_Sequence is String;
+ -- Alternative representation for a set of character values
+
+ function To_Set (Sequence : in Character_Sequence) return Character_Set;
+
+ function To_Set (Singleton : in Character) return Character_Set;
+
+ function To_Sequence (Set : in Character_Set) return Character_Sequence;
+
+ ------------------------------------
+ -- Character Mapping Declarations --
+ ------------------------------------
+
+ type Character_Mapping is private;
+ -- Representation for a character to character mapping:
+
+ function Value
+ (Map : in Character_Mapping;
+ Element : in Character)
+ return Character;
+
+ Identity : constant Character_Mapping;
+
+ ----------------------------
+ -- Operations on Mappings --
+ ----------------------------
+
+ function To_Mapping
+ (From, To : in Character_Sequence)
+ return Character_Mapping;
+
+ function To_Domain
+ (Map : in Character_Mapping)
+ return Character_Sequence;
+
+ function To_Range
+ (Map : in Character_Mapping)
+ return Character_Sequence;
+
+ type Character_Mapping_Function is
+ access function (From : in Character) return Character;
+
+ ------------------
+ -- Private Part --
+ ------------------
+
+private
+ pragma Inline (Is_In);
+ pragma Inline (Value);
+
+ type Character_Set_Internal is array (Character) of Boolean;
+ pragma Pack (Character_Set_Internal);
+
+ type Character_Set is new Character_Set_Internal;
+ -- Note: the reason for this level of derivation is to make sure
+ -- that the predefined logical operations on this type remain
+ -- accessible. The operations on Character_Set are overridden by
+ -- the defined operations in the spec, but the operations defined
+ -- on Character_Set_Internal remain visible.
+
+ Null_Set : constant Character_Set := (others => False);
+
+ type Character_Mapping is array (Character) of Character;
+
+ Identity : 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
+ 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.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
+
+end Ada.Strings.Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . S E A R C H --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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: This code is derived from the ADAR.CSH public domain Ada 83
+-- versions of the Appendix C string handling packages (code extracted
+-- from Ada.Strings.Fixed). A significant change is that we optimize the
+-- case of identity mappings for Count and Index, and also Index_Non_Blank
+-- is specialized (rather than using the general Index routine).
+
+
+with Ada.Strings.Maps; use Ada.Strings.Maps;
+
+package body Ada.Strings.Search is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Belongs
+ (Element : Character;
+ Set : Maps.Character_Set;
+ Test : Membership)
+ return Boolean;
+ pragma Inline (Belongs);
+ -- Determines if the given element is in (Test = Inside) or not in
+ -- (Test = Outside) the given character set.
+
+ -------------
+ -- Belongs --
+ -------------
+
+ function Belongs
+ (Element : Character;
+ Set : Maps.Character_Set;
+ Test : Membership)
+ return Boolean
+ is
+ begin
+ if Test = Inside then
+ return Is_In (Element, Set);
+ else
+ return not Is_In (Element, Set);
+ end if;
+ end Belongs;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ N : Natural;
+ J : Natural;
+
+ Mapped_Source : String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ N := 0;
+ J := Source'First;
+
+ while J <= Source'Last - (Pattern'Length - 1) loop
+ if Mapped_Source (J .. J + (Pattern'Length - 1)) = Pattern then
+ N := N + 1;
+ J := J + Pattern'Length;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : String (Source'Range);
+ N : Natural;
+ J : Natural;
+
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- We make sure Access_Check is unsuppressed so that the Mapping.all
+ -- call will generate a friendly Constraint_Error if the value for
+ -- Mapping is uninitialized (and hence null).
+
+ declare
+ pragma Unsuppress (Access_Check);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping.all (Source (J));
+ end loop;
+ end;
+
+ N := 0;
+ J := Source'First;
+
+ while J <= Source'Last - (Pattern'Length - 1) loop
+ if Mapped_Source (J .. J + (Pattern'Length - 1)) = Pattern then
+ N := N + 1;
+ J := J + Pattern'Length;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ function Count
+ (Source : in String;
+ Set : in Maps.Character_Set)
+ return Natural
+ is
+ N : Natural := 0;
+
+ begin
+ for J in Source'Range loop
+ if Is_In (Source (J), Set) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ First := J;
+
+ for K in J + 1 .. Source'Last loop
+ if not Belongs (Source (K), Set, Test) then
+ Last := K - 1;
+ return;
+ end if;
+ end loop;
+
+ -- Here if J indexes 1st char of token, and all chars
+ -- after J are in the token
+
+ Last := Source'Last;
+ return;
+ end if;
+ end loop;
+
+ -- Here if no token found
+
+ First := Source'First;
+ Last := 0;
+ end Find_Token;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ Cur_Index : Natural;
+ Mapped_Source : String (Source'Range);
+
+
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ -- Forwards case
+
+ if Going = Forward then
+ for J in 1 .. Source'Length - Pattern'Length + 1 loop
+ Cur_Index := Source'First + J - 1;
+
+ if Pattern = Mapped_Source
+ (Cur_Index .. Cur_Index + Pattern'Length - 1)
+ then
+ return Cur_Index;
+ end if;
+ end loop;
+
+ -- Backwards case
+
+ else
+ for J in reverse 1 .. Source'Length - Pattern'Length + 1 loop
+ Cur_Index := Source'First + J - 1;
+
+ if Pattern = Mapped_Source
+ (Cur_Index .. Cur_Index + Pattern'Length - 1)
+ then
+ return Cur_Index;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match found. Note that the loops are skipped
+ -- completely in the case of the pattern being longer than the source.
+
+ return 0;
+ end Index;
+
+ function Index (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : String (Source'Range);
+ Cur_Index : Natural;
+
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- We make sure Access_Check is unsuppressed so that the Mapping.all
+ -- call will generate a friendly Constraint_Error if the value for
+ -- Mapping is uninitialized (and hence null).
+
+ declare
+ pragma Unsuppress (Access_Check);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping.all (Source (J));
+ end loop;
+ end;
+
+ -- Forwards case
+
+ if Going = Forward then
+ for J in 1 .. Source'Length - Pattern'Length + 1 loop
+ Cur_Index := Source'First + J - 1;
+
+ if Pattern = Mapped_Source
+ (Cur_Index .. Cur_Index + Pattern'Length - 1)
+ then
+ return Cur_Index;
+ end if;
+ end loop;
+
+ -- Backwards case
+
+ else
+ for J in reverse 1 .. Source'Length - Pattern'Length + 1 loop
+ Cur_Index := Source'First + J - 1;
+
+ if Pattern = Mapped_Source
+ (Cur_Index .. Cur_Index + Pattern'Length - 1)
+ then
+ return Cur_Index;
+ end if;
+ end loop;
+ end if;
+
+ return 0;
+ end Index;
+
+ function Index
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ is
+ begin
+ -- Forwards case
+
+ if Going = Forward then
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+
+ -- Backwards case
+
+ else
+ for J in reverse Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : in String;
+ Going : in Direction := Forward)
+ return Natural
+ is
+ begin
+ if Going = Forward then
+ for J in Source'Range loop
+ if Source (J) /= ' ' then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'Range loop
+ if Source (J) /= ' ' then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+
+ end Index_Non_Blank;
+
+end Ada.Strings.Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . S E A R C H --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the search functions from Ada.Strings.Fixed. They
+-- are separated out because they are shared by Ada.Strings.Bounded and
+-- Ada.Strings.Unbounded, and we don't want to drag other irrelevant stuff
+-- from Ada.Strings.Fixed when using the other two packages. We make this
+-- a private package, since user programs should access these subprograms
+-- via one of the standard string packages.
+
+with Ada.Strings.Maps;
+
+private package Ada.Strings.Search is
+pragma Preelaborate (Search);
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in String;
+ Set : in Maps.Character_Set)
+ return Natural;
+
+
+ procedure Find_Token
+ (Source : in String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+end Ada.Strings.Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.31 $
+-- --
+-- 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.Strings.Fixed;
+with Ada.Strings.Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Unbounded is
+
+ use Ada.Finalization;
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&" (Left, Right : Unbounded_String) return Unbounded_String is
+ L_Length : constant Integer := Left.Reference.all'Length;
+ R_Length : constant Integer := Right.Reference.all'Length;
+ Length : constant Integer := L_Length + R_Length;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ Result.Reference.all (1 .. L_Length) := Left.Reference.all;
+ Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : String)
+ return Unbounded_String
+ is
+ L_Length : constant Integer := Left.Reference.all'Length;
+ Length : constant Integer := L_Length + Right'Length;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ Result.Reference.all (1 .. L_Length) := Left.Reference.all;
+ Result.Reference.all (L_Length + 1 .. Length) := Right;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : String;
+ Right : Unbounded_String)
+ return Unbounded_String
+ is
+ R_Length : constant Integer := Right.Reference.all'Length;
+ Length : constant Integer := Left'Length + R_Length;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ Result.Reference.all (1 .. Left'Length) := Left;
+ Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : Character)
+ return Unbounded_String
+ is
+ Length : constant Integer := Left.Reference.all'Length + 1;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ Result.Reference.all (1 .. Length - 1) := Left.Reference.all;
+ Result.Reference.all (Length) := Right;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Character;
+ Right : Unbounded_String)
+ return Unbounded_String
+ is
+ Length : constant Integer := Right.Reference.all'Length + 1;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ Result.Reference.all (1) := Left;
+ Result.Reference.all (2 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Character)
+ return Unbounded_String
+ is
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Left);
+ for J in Result.Reference'Range loop
+ Result.Reference (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : String)
+ return Unbounded_String
+ is
+ Len : constant Integer := Right'Length;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Left * Len);
+ for J in 1 .. Left loop
+ Result.Reference.all (Len * J - Len + 1 .. Len * J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_String)
+ return Unbounded_String
+ is
+ Len : constant Integer := Right.Reference.all'Length;
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Left * Len);
+ for I in 1 .. Left loop
+ Result.Reference.all (Len * I - Len + 1 .. Len * I) :=
+ Right.Reference.all;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : in Unbounded_String) return Boolean is
+ begin
+ return Left.Reference.all < Right.Reference.all;
+ end "<";
+
+ function "<"
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all < Right;
+ end "<";
+
+ function "<"
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Reference.all;
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<=" (Left, Right : in Unbounded_String) return Boolean is
+ begin
+ return Left.Reference.all <= Right.Reference.all;
+ end "<=";
+
+ function "<="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all <= Right;
+ end "<=";
+
+ function "<="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Reference.all;
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : in Unbounded_String) return Boolean is
+ begin
+ return Left.Reference.all = Right.Reference.all;
+ end "=";
+
+ function "="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all = Right;
+ end "=";
+
+ function "="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean
+ is
+ begin
+ return Left = Right.Reference.all;
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : in Unbounded_String) return Boolean is
+ begin
+ return Left.Reference.all > Right.Reference.all;
+ end ">";
+
+ function ">"
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all > Right;
+ end ">";
+
+ function ">"
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Reference.all;
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">=" (Left, Right : in Unbounded_String) return Boolean is
+ begin
+ return Left.Reference.all >= Right.Reference.all;
+ end ">=";
+
+ function ">="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all >= Right;
+ end ">=";
+
+ function ">="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Reference.all;
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_String) is
+ begin
+ -- Copy string, except we do not copy the statically allocated null
+ -- string, since it can never be deallocated.
+
+ if Object.Reference /= Null_String'Access then
+ Object.Reference := new String'(Object.Reference.all);
+ end if;
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in Unbounded_String)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + New_Item.Reference.all'Length;
+ Tmp : String_Access;
+
+ begin
+ Tmp := new String (1 .. Length);
+ Tmp (1 .. S_Length) := Source.Reference.all;
+ Tmp (S_Length + 1 .. Length) := New_Item.Reference.all;
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in String)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + New_Item'Length;
+ Tmp : String_Access;
+
+ begin
+ Tmp := new String (1 .. Length);
+ Tmp (1 .. S_Length) := Source.Reference.all;
+ Tmp (S_Length + 1 .. Length) := New_Item;
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in Character)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + 1;
+ Tmp : String_Access;
+
+ begin
+ Tmp := new String (1 .. Length);
+ Tmp (1 .. S_Length) := Source.Reference.all;
+ Tmp (S_Length + 1) := New_Item;
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end Append;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return Search.Count (Source.Reference.all, Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Search.Count (Source.Reference.all, Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set)
+ return Natural
+ is
+ begin
+ return Search.Count (Source.Reference.all, Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_String;
+ From : Positive;
+ Through : Natural)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String
+ (Fixed.Delete (Source.Reference.all, From, Through));
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_String;
+ From : in Positive;
+ Through : in Natural)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference :=
+ new String' (Fixed.Delete (Old.all, From, Through));
+ Free (Old);
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_String;
+ Index : Positive)
+ return Character
+ is
+ begin
+ if Index <= Source.Reference.all'Last then
+ return Source.Reference.all (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_String) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (String, String_Access);
+
+ begin
+ -- Note: Don't try to free statically allocated null string
+
+ if Object.Reference /= Null_String'Access then
+ Deallocate (Object.Reference);
+ Object.Reference := Null_Unbounded_String.Reference;
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Search.Find_Token (Source.Reference.all, Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (String, String_Access);
+
+ begin
+ -- Note: Don't try to free statically allocated null string
+
+ if X /= Null_Unbounded_String.Reference then
+ Deallocate (X);
+ end if;
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String (Fixed.Head (Source.Reference.all, Count, Pad));
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new String'(Fixed.Head (Old.all, Count, Pad));
+ Free (Old);
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Search.Index (Source.Reference.all, Set, Test, Going);
+ end Index;
+
+ function Index_Non_Blank
+ (Source : Unbounded_String;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Search.Index_Non_Blank (Source.Reference.all, Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_String) is
+ begin
+ Object.Reference := Null_Unbounded_String.Reference;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_String;
+ Before : Positive;
+ New_Item : String)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String
+ (Fixed.Insert (Source.Reference.all, Before, New_Item));
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_String;
+ Before : in Positive;
+ New_Item : in String)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference :=
+ new String' (Fixed.Insert (Source.Reference.all, Before, New_Item));
+ Free (Old);
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_String) return Natural is
+ begin
+ return Source.Reference.all'Length;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_String;
+ Position : Positive;
+ New_Item : String)
+ return Unbounded_String is
+
+ begin
+ return To_Unbounded_String
+ (Fixed.Overwrite (Source.Reference.all, Position, New_Item));
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_String;
+ Position : in Positive;
+ New_Item : in String)
+ is
+ NL : constant Integer := New_Item'Length;
+
+ begin
+ if Position <= Source.Reference'Length - NL + 1 then
+ Source.Reference (Position .. Position + NL - 1) := New_Item;
+
+ else
+ declare
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new
+ String'(Fixed.Overwrite (Old.all, Position, New_Item));
+ Free (Old);
+ end;
+ end if;
+ end Overwrite;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_String;
+ Index : Positive;
+ By : Character)
+ is
+ begin
+ if Index <= Source.Reference.all'Last then
+ Source.Reference.all (Index) := By;
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural;
+ By : String)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String
+ (Fixed.Replace_Slice (Source.Reference.all, Low, High, By));
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference :=
+ new String'(Fixed.Replace_Slice (Old.all, Low, High, By));
+ Free (Old);
+ end Replace_Slice;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural)
+ return String
+ is
+ Length : constant Natural := Source.Reference'Length;
+
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Length + 1 or else High > Length then
+ raise Index_Error;
+ else
+ return Source.Reference.all (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space)
+ return Unbounded_String is
+
+ begin
+ return
+ To_Unbounded_String (Fixed.Tail (Source.Reference.all, Count, Pad));
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new String'(Fixed.Tail (Old.all, Count, Pad));
+ Free (Old);
+ end Tail;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Source : Unbounded_String) return String is
+ begin
+ return Source.Reference.all;
+ end To_String;
+
+ -------------------------
+ -- To_Unbounded_String --
+ -------------------------
+
+ function To_Unbounded_String (Source : String) return Unbounded_String is
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Source'Length);
+ Result.Reference.all := Source;
+ return Result;
+ end To_Unbounded_String;
+
+ function To_Unbounded_String
+ (Length : in Natural)
+ return Unbounded_String
+ is
+ Result : Unbounded_String;
+
+ begin
+ Result.Reference := new String (1 .. Length);
+ return Result;
+ end To_Unbounded_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping)
+ is
+ begin
+ Fixed.Translate (Source.Reference.all, Mapping);
+ end Translate;
+
+ function Translate
+ (Source : in Unbounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ is
+ begin
+ Fixed.Translate (Source.Reference.all, Mapping);
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : in Unbounded_String;
+ Side : in Trim_End)
+ return Unbounded_String
+ is
+ begin
+ return To_Unbounded_String (Fixed.Trim (Source.Reference.all, Side));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Side : in Trim_End)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new String'(Fixed.Trim (Old.all, Side));
+ Free (Old);
+ end Trim;
+
+ function Trim
+ (Source : in Unbounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return Unbounded_String
+ is
+ begin
+ return
+ To_Unbounded_String (Fixed.Trim (Source.Reference.all, Left, Right));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ is
+ Old : String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new String'(Fixed.Trim (Old.all, Left, Right));
+ Free (Old);
+ end Trim;
+
+end Ada.Strings.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.20 $ --
+-- --
+-- 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 Ada.Strings.Maps;
+with Ada.Finalization;
+
+package Ada.Strings.Unbounded is
+pragma Preelaborate (Unbounded);
+
+ type Unbounded_String is private;
+
+ Null_Unbounded_String : constant Unbounded_String;
+
+ function Length (Source : Unbounded_String) return Natural;
+
+ type String_Access is access all String;
+
+ procedure Free (X : in out String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_String (Source : String) return Unbounded_String;
+ function To_Unbounded_String (Length : in Natural) return Unbounded_String;
+
+ function To_String (Source : Unbounded_String) return String;
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in Unbounded_String);
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in String);
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : in Character);
+
+ function "&" (Left, Right : Unbounded_String) return Unbounded_String;
+
+ function "&"
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Unbounded_String;
+
+ function "&"
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Unbounded_String;
+
+ function "&"
+ (Left : in Unbounded_String;
+ Right : in Character)
+ return Unbounded_String;
+
+ function "&"
+ (Left : in Character;
+ Right : in Unbounded_String)
+ return Unbounded_String;
+
+ function Element
+ (Source : in Unbounded_String;
+ Index : in Positive)
+ return Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_String;
+ Index : in Positive;
+ By : Character);
+
+ function Slice
+ (Source : in Unbounded_String;
+ Low : in Positive;
+ High : in Natural)
+ return String;
+
+ function "=" (Left, Right : in Unbounded_String) return Boolean;
+
+ function "="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean;
+
+ function "="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean;
+
+ function "<" (Left, Right : in Unbounded_String) return Boolean;
+
+ function "<"
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean;
+
+ function "<"
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean;
+
+ function "<=" (Left, Right : in Unbounded_String) return Boolean;
+
+ function "<="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean;
+
+ function "<="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean;
+
+ function ">" (Left, Right : in Unbounded_String) return Boolean;
+
+ function ">"
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean;
+
+ function ">"
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean;
+
+ function ">=" (Left, Right : in Unbounded_String) return Boolean;
+
+ function ">="
+ (Left : in Unbounded_String;
+ Right : in String)
+ return Boolean;
+
+ function ">="
+ (Left : in String;
+ Right : in Unbounded_String)
+ return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in Unbounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in Unbounded_String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_String;
+ Set : in Maps.Character_Set)
+ return Natural;
+
+ procedure Find_Token
+ (Source : in Unbounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : in Unbounded_String;
+ Mapping : in Maps.Character_Mapping)
+ return Unbounded_String;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping);
+
+ function Translate
+ (Source : in Unbounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Unbounded_String;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : in Maps.Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : in Unbounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String)
+ return Unbounded_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String);
+
+ function Insert
+ (Source : in Unbounded_String;
+ Before : in Positive;
+ New_Item : in String)
+ return Unbounded_String;
+
+ procedure Insert
+ (Source : in out Unbounded_String;
+ Before : in Positive;
+ New_Item : in String);
+
+ function Overwrite
+ (Source : in Unbounded_String;
+ Position : in Positive;
+ New_Item : in String)
+ return Unbounded_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_String;
+ Position : in Positive;
+ New_Item : in String);
+
+ function Delete
+ (Source : in Unbounded_String;
+ From : in Positive;
+ Through : in Natural)
+ return Unbounded_String;
+
+ procedure Delete
+ (Source : in out Unbounded_String;
+ From : in Positive;
+ Through : in Natural);
+
+ function Trim
+ (Source : in Unbounded_String;
+ Side : in Trim_End)
+ return Unbounded_String;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Side : in Trim_End);
+
+ function Trim
+ (Source : in Unbounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return Unbounded_String;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set);
+
+ function Head
+ (Source : in Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return Unbounded_String;
+
+ procedure Head
+ (Source : in out Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space);
+
+ function Tail
+ (Source : in Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space)
+ return Unbounded_String;
+
+ procedure Tail
+ (Source : in out Unbounded_String;
+ Count : in Natural;
+ Pad : in Character := Space);
+
+ function "*"
+ (Left : in Natural;
+ Right : in Character)
+ return Unbounded_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in String)
+ return Unbounded_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Unbounded_String)
+ return Unbounded_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ Null_String : aliased String := "";
+
+ function To_Unbounded (S : String) return Unbounded_String
+ renames To_Unbounded_String;
+
+ type Unbounded_String is new AF.Controlled with record
+ Reference : String_Access := Null_String'Access;
+ end record;
+
+ pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
+
+ pragma Finalize_Storage_Only (Unbounded_String);
+
+ procedure Initialize (Object : in out Unbounded_String);
+ procedure Adjust (Object : in out Unbounded_String);
+ procedure Finalize (Object : in out Unbounded_String);
+
+ Null_Unbounded_String : constant Unbounded_String :=
+ (AF.Controlled with Reference => Null_String'Access);
+
+end Ada.Strings.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T R E A M _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.32 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System; use System;
+with System.File_IO;
+with System.Soft_Links;
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body Ada.Streams.Stream_IO is
+
+ package FIO renames System.File_IO;
+ package SSL renames System.Soft_Links;
+
+ subtype AP is FCB.AFCB_Ptr;
+
+ function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
+ function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+ use type FCB.File_Mode;
+ use type FCB.Shared_Status_Type;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Set_Position (File : in File_Type);
+ -- Sets file position pointer according to value of current index
+
+ -------------------
+ -- AFCB_Allocate --
+ -------------------
+
+ function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is
+ begin
+ return new Stream_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ -- No special processing required for closing Stream_IO file
+
+ procedure AFCB_Close (File : access Stream_AFCB) is
+ begin
+ null;
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Stream_AFCB) is
+ type FCB_Ptr is access all Stream_AFCB;
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ -----------
+ -- 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
+ File_Control_Block : Stream_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'S',
+ Creat => True,
+ Text => False);
+ File.Last_Op := Op_Write;
+ 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
+ FIO.Check_Read_Status (AP (File));
+ return Count (File.Index) > Size (File);
+ end End_Of_File;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : in out File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
+ ----------
+ -- 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
+ FIO.Check_File_Open (AP (File));
+ return Count (File.Index);
+ 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_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
+ File_Control_Block : Stream_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'S',
+ Creat => False,
+ Text => False);
+
+ -- Ensure that the stream index is set properly (e.g., for Append_File)
+
+ Reset (File, Mode);
+
+ File.Last_Op := Op_Read;
+ end Open;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : in File_Type;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset;
+ From : in Positive_Count)
+ is
+ begin
+ Set_Index (File, From);
+ Read (File, Item, Last);
+ end Read;
+
+ procedure Read
+ (File : in File_Type;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ Nread : size_t;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If last operation was not a read, or if in file sharing mode,
+ -- then reset the physical pointer of the file to match the index
+ -- We lock out task access over the two operations in this case.
+
+ if File.Last_Op /= Op_Read
+ or else File.Shared_Status = FCB.Yes
+ then
+ if End_Of_File (File) then
+ raise End_Error;
+ end if;
+
+ Locked_Processing : begin
+ SSL.Lock_Task.all;
+ Set_Position (File);
+ FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
+ end Locked_Processing;
+
+ else
+ FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
+ end if;
+
+ File.Index := File.Index + Count (Nread);
+ Last := Item'First + Stream_Element_Offset (Nread) - 1;
+ File.Last_Op := Op_Read;
+ end Read;
+
+ -- This version of Read is the primitive operation on the underlying
+ -- Stream type, used when a Stream_IO file is treated as a Stream
+
+ procedure Read
+ (File : in out Stream_AFCB;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset)
+ is
+ begin
+ Read (File'Unchecked_Access, Item, Last);
+ end Read;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (File : in out File_Type; Mode : in File_Mode) is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ -- Reset file index to start of file for read/write cases. For
+ -- the append case, the Set_Mode call repositions the index.
+
+ File.Index := 1;
+ Set_Mode (File, Mode);
+ end Reset;
+
+ procedure Reset (File : in out File_Type) is
+ begin
+ Reset (File, To_SIO (File.Mode));
+ end Reset;
+
+ ---------------
+ -- Set_Index --
+ ---------------
+
+ procedure Set_Index (File : in File_Type; To : in Positive_Count) is
+ begin
+ FIO.Check_File_Open (AP (File));
+ File.Index := Count (To);
+ File.Last_Op := Op_Other;
+ end Set_Index;
+
+ --------------
+ -- Set_Mode --
+ --------------
+
+ procedure Set_Mode (File : in out File_Type; Mode : in File_Mode) is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ -- If we are switching from read to write, or vice versa, and
+ -- we are not already open in update mode, then reopen in update
+ -- mode now. Note that we can use Inout_File as the mode for the
+ -- call since File_IO handles all modes for all file types.
+
+ if ((File.Mode = FCB.In_File) /= (Mode = In_File))
+ and then not File.Update_Mode
+ then
+ FIO.Reset (AP (File), FCB.Inout_File);
+ File.Update_Mode := True;
+ end if;
+
+ -- Set required mode and position to end of file if append mode
+
+ File.Mode := To_FCB (Mode);
+ FIO.Append_Set (AP (File));
+
+ if File.Mode = FCB.Append_File then
+ File.Index := Count (ftell (File.Stream)) + 1;
+ end if;
+
+ File.Last_Op := Op_Other;
+ end Set_Mode;
+
+ ------------------
+ -- Set_Position --
+ ------------------
+
+ procedure Set_Position (File : in File_Type) is
+ begin
+ if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then
+ raise Use_Error;
+ end if;
+ end Set_Position;
+
+ ----------
+ -- Size --
+ ----------
+
+ function Size (File : in File_Type) return Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ if File.File_Size = -1 then
+ File.Last_Op := Op_Other;
+
+ if fseek (File.Stream, 0, SEEK_END) /= 0 then
+ raise Device_Error;
+ end if;
+
+ File.File_Size := Stream_Element_Offset (ftell (File.Stream));
+ end if;
+
+ return Count (File.File_Size);
+ end Size;
+
+ ------------
+ -- Stream --
+ ------------
+
+ function Stream (File : in File_Type) return Stream_Access is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return Stream_Access (File);
+ end Stream;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (File : in File_Type;
+ Item : in Stream_Element_Array;
+ To : in Positive_Count)
+ is
+ begin
+ Set_Index (File, To);
+ Write (File, Item);
+ end Write;
+
+ procedure Write (File : in File_Type; Item : in Stream_Element_Array) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ -- If last operation was not a write, or if in file sharing mode,
+ -- then reset the physical pointer of the file to match the index
+ -- We lock out task access over the two operations in this case.
+
+ if File.Last_Op /= Op_Write
+ or else File.Shared_Status = FCB.Yes
+ then
+ Locked_Processing : begin
+ SSL.Lock_Task.all;
+ Set_Position (File);
+ FIO.Write_Buf (AP (File), Item'Address, Item'Length);
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
+ end Locked_Processing;
+
+ else
+ FIO.Write_Buf (AP (File), Item'Address, Item'Length);
+ end if;
+
+ File.Index := File.Index + Item'Length;
+ File.Last_Op := Op_Write;
+ File.File_Size := -1;
+ end Write;
+
+ -- This version of Write is the primitive operation on the underlying
+ -- Stream type, used when a Stream_IO file is treated as a Stream
+
+ procedure Write
+ (File : in out Stream_AFCB;
+ Item : in Ada.Streams.Stream_Element_Array)
+ is
+ begin
+ Write (File'Unchecked_Access, Item);
+ end Write;
+
+end Ada.Streams.Stream_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R E A M S . S T R E A M _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.14 $ --
+-- --
+-- 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.File_Control_Block;
+
+package Ada.Streams.Stream_IO is
+
+ type Stream_Access is access all Root_Stream_Type'Class;
+
+ 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)
+
+ type Count is new Stream_Element_Offset
+ range 0 .. Stream_Element_Offset'Last;
+
+ subtype Positive_Count is Count range 1 .. Count'Last;
+ -- Index into file, in stream elements
+
+ ---------------------
+ -- 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;
+ function End_Of_File (File : in File_Type) return Boolean;
+
+ function Stream (File : in File_Type) return Stream_Access;
+
+ -----------------------------
+ -- Input-Output Operations --
+ -----------------------------
+
+ procedure Read
+ (File : in File_Type;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset;
+ From : in Positive_Count);
+
+ procedure Read
+ (File : in File_Type;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset);
+
+ procedure Write
+ (File : in File_Type;
+ Item : in Stream_Element_Array;
+ To : in Positive_Count);
+
+ procedure Write
+ (File : in File_Type;
+ Item : in Stream_Element_Array);
+
+ ----------------------------------------
+ -- Operations on Position within File --
+ ----------------------------------------
+
+ 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;
+
+ procedure Set_Mode (File : in out File_Type; Mode : in File_Mode);
+
+ procedure Flush (File : in out File_Type);
+
+ ----------------
+ -- 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
+ package FCB renames System.File_Control_Block;
+
+ -----------------------------
+ -- Stream_IO Control Block --
+ -----------------------------
+
+ type Operation is (Op_Read, Op_Write, Op_Other);
+ -- Type used to record last operation (to optimize sequential operations)
+
+ type Stream_AFCB is new FCB.AFCB with record
+ Index : Count := 1;
+ -- Current Index value
+
+ File_Size : Stream_Element_Offset := -1;
+ -- Cached value of File_Size, so that we do not keep recomputing it
+ -- when not necessary (otherwise End_Of_File becomes gruesomely slow).
+ -- A value of minus one means that there is no cached value.
+
+ Last_Op : Operation := Op_Other;
+ -- Last operation performed on file, used to avoid unnecessary
+ -- repositioning between successive read or write operations.
+
+ Update_Mode : Boolean := False;
+ -- Set if the mode is changed from write to read or vice versa.
+ -- Indicates that the file has been reopened in update mode.
+
+ end record;
+
+ type File_Type is access all Stream_AFCB;
+
+ function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr;
+
+ procedure AFCB_Close (File : access Stream_AFCB);
+ procedure AFCB_Free (File : access Stream_AFCB);
+
+ procedure Read
+ (File : in out Stream_AFCB;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset);
+ -- Read operation used when Stream_IO file is treated directly as Stream
+
+ procedure Write
+ (File : in out Stream_AFCB;
+ Item : in Ada.Streams.Stream_Element_Array);
+ -- Write operation used when Stream_IO file is treated directly as Stream
+
+end Ada.Streams.Stream_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Unbounded.Aux is
+
+ ----------------
+ -- Get_String --
+ ----------------
+
+ function Get_String (U : Unbounded_String) return String_Access is
+ begin
+ return U.Reference;
+ end Get_String;
+
+ ----------------
+ -- Set_String --
+ ----------------
+
+ procedure Set_String (UP : in out Unbounded_String; S : String) is
+ begin
+ if UP.Reference'Length = S'Length then
+ UP.Reference.all := S;
+
+ else
+ declare
+ subtype String_1 is String (1 .. S'Length);
+ Tmp : String_Access;
+
+ begin
+ Tmp := new String'(String_1 (S));
+ Finalize (UP);
+ UP.Reference := Tmp;
+ end;
+ end if;
+ end Set_String;
+
+ procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
+ begin
+ Finalize (UP);
+ UP.Reference := S;
+ end Set_String;
+
+end Ada.Strings.Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . A U X --
+-- --
+-- S p e c --
+-- --
+-- $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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package of Ada.Strings.Unbounded provides some specialized
+-- access functions which are intended to allow more efficient use of the
+-- facilities of Ada.Strings.Unbounded, particularly by other layered
+-- utilities (such as GNAT.Patterns).
+
+package Ada.Strings.Unbounded.Aux is
+pragma Preelaborate (Aux);
+
+ function Get_String (U : Unbounded_String) return String_Access;
+ pragma Inline (Get_String);
+ -- This function returns the internal string pointer used in the
+ -- representation of an unbounded string. There is no copy involved,
+ -- so the value obtained references the same string as the original
+ -- unbounded string. The characters of this string may not be modified
+ -- via the returned pointer, and are valid only as long as the original
+ -- unbounded string is not modified. Violating either of these two
+ -- rules results in erroneous execution.
+ --
+ -- This function is much more efficient than the use of To_String
+ -- since it avoids the need to copy the string. The lower bound of the
+ -- referenced string returned by this call is always one.
+
+ procedure Set_String (UP : in out Unbounded_String; S : String);
+ pragma Inline (Set_String);
+ -- This function sets the string contents of the referenced unbounded
+ -- string to the given string value. It is significantly more efficient
+ -- than the use of To_Unbounded_String with an assignment, since it
+ -- avoids the necessity of messing with finalization chains. The lower
+ -- bound of the string S is not required to be one.
+
+ procedure Set_String (UP : in out Unbounded_String; S : String_Access);
+ pragma Inline (Set_String);
+ -- This version of Set_String takes a string access value, rather than a
+ -- string. The lower bound of the string value is required to be one, and
+ -- this requirement is not checked.
+
+end Ada.Strings.Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ B O U N D E D --
+-- --
+-- 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.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
+with Ada.Strings.Wide_Search;
+
+package body Ada.Strings.Wide_Bounded is
+
+ package body Generic_Bounded_Length is
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+
+ Nlen : constant Natural := Llen + Right'Length;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+ end if;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left'Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+
+ begin
+ if Llen = Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Result.Length) := Right;
+ end if;
+
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Rlen : Length_Range := Right.Length;
+
+ begin
+ if Rlen = Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_Character)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+
+ begin
+ if Left > Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Length := Left;
+
+ for J in 1 .. Left loop
+ Result.Data (J) := Right;
+ end loop;
+ end if;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Index_Error;
+ else
+ Result.Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) := Right;
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Pos : Positive := 1;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) :=
+ Right.Data (1 .. Rlen);
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length);
+ end "<";
+
+ function "<"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) < Right;
+ end "<";
+
+ function "<"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Data (1 .. Right.Length);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length);
+ end "<=";
+
+ function "<="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Data (1 .. Right.Length);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Length = Right.Length
+ and then Left.Data (1 .. Left.Length) =
+ Right.Data (1 .. Right.Length);
+ end "=";
+
+ function "="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Length = Right'Length
+ and then Left.Data (1 .. Left.Length) = Right;
+ end "=";
+
+ function "="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left'Length = Right.Length
+ and then Left = Right.Data (1 .. Right.Length);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length);
+ end ">";
+
+ function ">"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) > Right;
+ end ">";
+
+ function ">"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Data (1 .. Right.Length);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length);
+ end ">=";
+
+ function ">="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Length) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Data (1 .. Right.Length);
+ end ">=";
+
+ ------------
+ -- Append --
+ ------------
+
+ -- Case of Bounded_Wide_String and Bounded_Wide_String
+
+ function Append
+ (Left, Right : in Bounded_Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+ Rlen : constant Length_Range := New_Item.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Source.Data := New_Item.Data;
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of Bounded_Wide_String and Wide_String
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+ Rlen : constant Length_Range := Right'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right (Right'First .. Right'First - 1 +
+ Max_Length - Llen);
+
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right (Right'Last - (Max_Length - 1) .. Right'Last);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+ Rlen : constant Length_Range := New_Item'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item;
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item (New_Item'First ..
+ New_Item'First - 1 + Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - (Max_Length - 1) ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of Wide_String and Bounded_Wide_String
+
+ function Append
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left'Length;
+ Rlen : constant Length_Range := Right.Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Left (Left'First .. Left'First + (Max_Length - 1));
+
+ else
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right.Data (Rlen - (Max_Length - 1) .. Rlen);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Append;
+
+ -- Case of Bounded_Wide_String and Wide_Character
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Llen : constant Length_Range := Left.Length;
+
+ begin
+ if Llen < Max_Length then
+ Result.Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1) := Right;
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ return Left;
+
+ when Strings.Left =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length - 1) :=
+ Left.Data (2 .. Max_Length);
+ Result.Data (Max_Length) := Right;
+ return Result;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_Character;
+ Drop : in Truncation := Error)
+ is
+ Llen : constant Length_Range := Source.Length;
+
+ begin
+ if Llen < Max_Length then
+ Source.Length := Llen + 1;
+ Source.Data (Llen + 1) := New_Item;
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ null;
+
+ when Strings.Left =>
+ Source.Data (1 .. Max_Length - 1) :=
+ Source.Data (2 .. Max_Length);
+ Source.Data (Max_Length) := New_Item;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Append;
+
+ -- Case of Wide_Character and Bounded_Wide_String
+
+ function Append
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Rlen : constant Length_Range := Right.Length;
+
+ begin
+ if Rlen < Max_Length then
+ Result.Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Length := Max_Length;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - 1);
+ return Result;
+
+ when Strings.Left =>
+ return Right;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Append;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Count
+ (Source.Data (1 .. Source.Length), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Count
+ (Source.Data (1 .. Source.Length), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural
+ is
+ begin
+ return Wide_Search.Count (Source.Data (1 .. Source.Length), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : in Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Bounded_Wide_String
+ is
+ Slen : constant Natural := Source.Length;
+ Num_Delete : constant Integer := Through - From + 1;
+ Result : Bounded_Wide_String;
+
+ begin
+ if Num_Delete <= 0 then
+ return Source;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Result.Length := From - 1;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ return Result;
+
+ else
+ Result.Length := Slen - Num_Delete;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ Result.Data (From .. Result.Length) :=
+ Source.Data (Through + 1 .. Slen);
+ return Result;
+ end if;
+ end Delete;
+
+ procedure Delete
+ (Source : in out Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ is
+ Slen : constant Natural := Source.Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Source.Length := From - 1;
+
+ else
+ Source.Length := Slen - Num_Delete;
+ Source.Data (From .. Source.Length) :=
+ Source.Data (Through + 1 .. Slen);
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : in Bounded_Wide_String;
+ Index : in Positive)
+ return Wide_Character
+ is
+ begin
+ if Index in 1 .. Source.Length then
+ return Source.Data (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Element;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Wide_Search.Find_Token
+ (Source.Data (1 .. Source.Length), Set, Test, First, Last);
+ end Find_Token;
+
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Length := Count;
+ Result.Data (1 .. Count) := Source.Data (1 .. Count);
+
+ elsif Count <= Max_Length then
+ Result.Length := Count;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Max_Length - Npad) :=
+ Source.Data (Count - Max_Length + 1 .. Slen);
+ Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
+ (others => Pad);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Head;
+
+ procedure Head
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ is
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : Wide_String (1 .. Max_Length);
+
+ begin
+ if Npad <= 0 then
+ Source.Length := Count;
+
+ elsif Count <= Max_Length then
+ Source.Length := Count;
+ Source.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad > Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Temp := Source.Data;
+ Source.Data (1 .. Max_Length - Npad) :=
+ Temp (Count - Max_Length + 1 .. Slen);
+
+ for J in Max_Length - Npad + 1 .. Max_Length loop
+ Source.Data (J) := Pad;
+ end loop;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Strings.Direction := Strings.Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Strings.Membership := Strings.Inside;
+ Going : in Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Length), Set, Test, Going);
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : in Bounded_Wide_String;
+ Going : in Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Index_Non_Blank
+ (Source.Data (1 .. Source.Length), Going);
+ end Index_Non_Blank;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : in Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Slen : constant Natural := Source.Length;
+ Nlen : constant Natural := New_Item'Length;
+ Tlen : constant Natural := Slen + Nlen;
+ Blen : constant Natural := Before - 1;
+ Alen : constant Integer := Slen - Blen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Bounded_Wide_String;
+
+ -- Tlen is the length of the total string before possible truncation.
+ -- Blen, Alen are the lengths of the before and after pieces of the
+ -- source string.
+
+ begin
+ if Alen < 0 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Droplen <= 0 then
+ Result.Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Tlen) :=
+ Source.Data (Before .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Before .. Max_Length) :=
+ New_Item (New_Item'First
+ .. New_Item'First + Max_Length - Before);
+ else
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Max_Length) :=
+ Source.Data (Before .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (Before .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ New_Item (New_Item'Last - (Max_Length - Alen) + 1
+ .. New_Item'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) :=
+ New_Item;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Insert;
+
+ procedure Insert
+ (Source : in out Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Insert (Source, Before, New_Item, Drop);
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : in Bounded_Wide_String) return Length_Range is
+ begin
+ return Source.Length;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : in Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Endpos : constant Natural := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif New_Item'Length = 0 then
+ return Source;
+
+ elsif Endpos <= Slen then
+ Result.Length := Source.Length;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ elsif Endpos <= Max_Length then
+ Result.Length := Endpos;
+ Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ else
+ Result.Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Position - 1) :=
+ Source.Data (1 .. Position - 1);
+
+ Result.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+ return Result;
+
+ when Strings.Left =>
+ if New_Item'Length >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+ return Result;
+
+ else
+ Result.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+ Result.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ return Result;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ Endpos : constant Positive := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Endpos <= Slen then
+ Source.Data (Position .. Endpos) := New_Item;
+
+ elsif Endpos <= Max_Length then
+ Source.Data (Position .. Endpos) := New_Item;
+ Source.Length := Endpos;
+
+ else
+ Source.Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+
+ when Strings.Left =>
+ if New_Item'Length > Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+
+ Source.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Overwrite;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Bounded_Wide_String;
+ Index : in Positive;
+ By : in Wide_Character)
+ is
+ begin
+ if Index <= Source.Length then
+ Source.Data (Index) := By;
+ else
+ raise Ada.Strings.Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : in Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Slen : constant Natural := Source.Length;
+
+ begin
+ if Low > Slen + 1 then
+ raise Strings.Index_Error;
+
+ elsif High < Low then
+ return Insert (Source, Low, By, Drop);
+
+ else
+ declare
+ Blen : constant Natural := Natural'Max (0, Low - 1);
+ Alen : constant Natural := Natural'Max (0, Slen - High);
+ Tlen : constant Natural := Blen + By'Length + Alen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Bounded_Wide_String;
+
+ -- Tlen is the total length of the result string before any
+ -- truncation. Blen and Alen are the lengths of the pieces
+ -- of the original string that end up in the result string
+ -- before and after the replaced slice.
+
+ begin
+ if Droplen <= 0 then
+ Result.Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Tlen) :=
+ Source.Data (High + 1 .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Low .. Max_Length) :=
+ By (By'First .. By'First + Max_Length - Low);
+ else
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Max_Length) :=
+ Source.Data (High + 1 .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (High + 1 .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) := By;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Replace_Slice (Source, Low, High, By, Drop);
+ end Replace_Slice;
+
+ ---------------
+ -- Replicate --
+ ---------------
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Wide_Character;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+
+ begin
+ if Count <= Max_Length then
+ Result.Length := Count;
+
+ elsif Drop = Strings.Error then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Length := Max_Length;
+ end if;
+
+ Result.Data (1 .. Result.Length) := (others => Item);
+ return Result;
+ end Replicate;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Length : constant Integer := Count * Item'Length;
+ Result : Bounded_Wide_String;
+ Indx : Positive;
+
+ begin
+ if Length <= Max_Length then
+ Result.Length := Length;
+
+ if Length > 0 then
+ Indx := 1;
+
+ for J in 1 .. Count loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+ end if;
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Indx := 1;
+
+ while Indx + Item'Length <= Max_Length + 1 loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+
+ Result.Data (Indx .. Max_Length) :=
+ Item (Item'First .. Item'First + Max_Length - Indx);
+
+ when Strings.Left =>
+ Indx := Max_Length;
+
+ while Indx - Item'Length >= 1 loop
+ Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
+ Indx := Indx - Item'Length;
+ end loop;
+
+ Result.Data (1 .. Indx) :=
+ Item (Item'Last - Indx + 1 .. Item'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Replicate;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Bounded_Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ begin
+ return Replicate (Count, Item.Data (1 .. Item.Length), Drop);
+ end Replicate;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Bounded_Wide_String;
+ Low : Positive;
+ High : Natural)
+ return Wide_String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Length + 1 or else High > Source.Length then
+ raise Index_Error;
+
+ else
+ declare
+ Result : Wide_String (1 .. High - Low + 1);
+
+ begin
+ Result := Source.Data (Low .. High);
+ return Result;
+ end;
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Length := Count;
+ Result.Data (1 .. Count) :=
+ Source.Data (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Result.Length := Count;
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
+
+ else
+ Result.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Max_Length) :=
+ Source.Data (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (1 .. Max_Length - Slen) := (others => Pad);
+ Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Source.Data (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Tail;
+
+ procedure Tail
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ is
+ Slen : constant Natural := Source.Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : Wide_String (1 .. Max_Length) := Source.Data;
+
+ begin
+ if Npad <= 0 then
+ Source.Length := Count;
+ Source.Data (1 .. Count) :=
+ Temp (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Source.Length := Count;
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
+
+ else
+ Source.Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Max_Length) :=
+ Temp (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ for J in 1 .. Max_Length - Slen loop
+ Source.Data (J) := Pad;
+ end loop;
+
+ Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Temp (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Tail;
+
+ ----------------------------
+ -- To_Bounded_Wide_String --
+ ----------------------------
+
+ function To_Bounded_Wide_String
+ (Source : in Wide_String;
+ Drop : in Strings.Truncation := Strings.Error)
+ return Bounded_Wide_String
+ is
+ Slen : constant Natural := Source'Length;
+ Result : Bounded_Wide_String;
+
+ begin
+ if Slen <= Max_Length then
+ Result.Length := Slen;
+ Result.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Result.Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end To_Bounded_Wide_String;
+
+ --------------------
+ -- To_Wide_String --
+ --------------------
+
+ function To_Wide_String
+ (Source : in Bounded_Wide_String)
+ return Wide_String
+ is
+ begin
+ return Source.Data (1 .. Source.Length);
+ end To_Wide_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+
+ begin
+ Result.Length := Source.Length;
+
+ for J in 1 .. Source.Length loop
+ Result.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ is
+ begin
+ for J in 1 .. Source.Length loop
+ Source.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+ end Translate;
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+
+ begin
+ Result.Length := Source.Length;
+
+ for J in 1 .. Source.Length loop
+ Result.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ is
+ begin
+ for J in 1 .. Source.Length loop
+ Source.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Side : in Trim_End)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+ Last : Natural := Source.Length;
+ First : Positive := 1;
+
+ begin
+ if Side = Left or else Side = Both then
+ while First <= Last and then Source.Data (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Source.Data (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Result.Length := Last - First + 1;
+ Result.Data (1 .. Result.Length) := Source.Data (First .. Last);
+ return Result;
+
+ end Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Side : in Trim_End)
+ is
+ Last : Length_Range := Source.Length;
+ First : Positive := 1;
+ Temp : Wide_String (1 .. Max_Length);
+
+ begin
+ Temp (1 .. Last) := Source.Data (1 .. Last);
+
+ if Side = Left or else Side = Both then
+ while First <= Last and then Temp (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Temp (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Source.Length := Last - First + 1;
+ Source.Data (1 .. Source.Length) := Temp (First .. Last);
+
+ end Trim;
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Bounded_Wide_String
+ is
+ Result : Bounded_Wide_String;
+
+ begin
+ for First in 1 .. Source.Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ Result.Length := Last - First + 1;
+ Result.Data (1 .. Result.Length) :=
+ Source.Data (First .. Last);
+ return Result;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Result.Length := 0;
+ return Result;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ is
+ begin
+ for First in 1 .. Source.Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ if First = 1 then
+ Source.Length := Last;
+ return;
+ else
+ Source.Length := Last - First + 1;
+ Source.Data (1 .. Source.Length) :=
+ Source.Data (First .. Last);
+ return;
+ end if;
+ end if;
+ end loop;
+
+ Source.Length := 0;
+ return;
+ end if;
+ end loop;
+
+ Source.Length := 0;
+ end Trim;
+
+ end Generic_Bounded_Length;
+
+end Ada.Strings.Wide_Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- 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.Strings.Wide_Maps;
+
+package Ada.Strings.Wide_Bounded is
+pragma Preelaborate (Wide_Bounded);
+
+ generic
+ Max : Positive;
+ -- Maximum length of a Bounded_Wide_String
+
+ package Generic_Bounded_Length is
+
+ Max_Length : constant Positive := Max;
+
+ type Bounded_Wide_String is private;
+
+ Null_Bounded_Wide_String : constant Bounded_Wide_String;
+
+ subtype Length_Range is Natural range 0 .. Max_Length;
+
+ function Length (Source : in Bounded_Wide_String) return Length_Range;
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Bounded_Wide_String
+ (Source : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function To_Wide_String
+ (Source : in Bounded_Wide_String)
+ return Wide_String;
+
+ function Append
+ (Left, Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Append
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Append
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Bounded_Wide_String;
+ Drop : in Truncation := Error);
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error);
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_Character;
+ Drop : in Truncation := Error);
+
+ function "&"
+ (Left, Right : in Bounded_Wide_String)
+ return Bounded_Wide_String;
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Bounded_Wide_String;
+
+ function "&"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String;
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character)
+ return Bounded_Wide_String;
+
+ function "&"
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String;
+
+ function Element
+ (Source : in Bounded_Wide_String;
+ Index : in Positive)
+ return Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Bounded_Wide_String;
+ Index : in Positive;
+ By : in Wide_Character);
+
+ function Slice
+ (Source : in Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural)
+ return Wide_String;
+
+ function "="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function "="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Bounded_Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean;
+
+ ----------------------
+ -- Search Functions --
+ ----------------------
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in Bounded_Wide_String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural;
+
+ procedure Find_Token
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- Wide_String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Bounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping);
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Bounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- Wide_String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : in Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error);
+
+ function Insert
+ (Source : in Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Insert
+ (Source : in out Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error);
+
+ function Overwrite
+ (Source : in Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error);
+
+ function Delete
+ (Source : in Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Bounded_Wide_String;
+
+ procedure Delete
+ (Source : in out Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural);
+
+ ---------------------------------
+ -- Wide_String Selector Subprograms --
+ ---------------------------------
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Side : in Trim_End)
+ return Bounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Side : in Trim_End);
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Bounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set);
+
+ function Head
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Head
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error);
+
+ function Tail
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ procedure Tail
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error);
+
+ ------------------------------------
+ -- Wide_String Constructor Subprograms --
+ ------------------------------------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_Character)
+ return Bounded_Wide_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_String)
+ return Bounded_Wide_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Wide_Character;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String;
+
+ private
+ Wide_NUL : constant Wide_Character := Wide_Character'Val (0);
+
+ type Bounded_Wide_String is record
+ Length : Length_Range := 0;
+ Data : Wide_String (1 .. Max_Length);
+ end record;
+
+ Null_Bounded_Wide_String : constant Bounded_Wide_String :=
+ (Length => 0, Data => (1 .. Max_Length => Wide_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_Wide_String);
+ pragma Inline (To_Wide_String);
+
+ end Generic_Bounded_Length;
+
+end Ada.Strings.Wide_Bounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ F I X E D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.17 $ --
+-- --
+-- 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 Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
+with Ada.Strings.Wide_Search;
+
+package body Ada.Strings.Wide_Fixed is
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ renames Ada.Strings.Wide_Search.Index;
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Wide_Search.Index;
+
+ function Index
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ renames Ada.Strings.Wide_Search.Index;
+
+ function Index_Non_Blank
+ (Source : in Wide_String;
+ Going : in Direction := Forward)
+ return Natural
+ renames Ada.Strings.Wide_Search.Index_Non_Blank;
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ renames Ada.Strings.Wide_Search.Count;
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ renames Ada.Strings.Wide_Search.Count;
+
+ function Count
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural
+ renames Ada.Strings.Wide_Search.Count;
+
+ procedure Find_Token
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Ada.Strings.Wide_Search.Find_Token;
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_Character)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Left);
+
+ begin
+ for J in Result'Range loop
+ Result (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_String)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Left * Right'Length);
+ Ptr : Integer := 1;
+
+ begin
+ for J in 1 .. Left loop
+ Result (Ptr .. Ptr + Right'Length - 1) := Right;
+ Ptr := Ptr + Right'Length;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : in Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Wide_String
+ is
+ begin
+ if From not in Source'Range
+ or else Through > Source'Last
+ then
+ raise Index_Error;
+
+ elsif From > Through then
+ return Source;
+
+ else
+ declare
+ Result : constant Wide_String :=
+ Source (Source'First .. From - 1) &
+ Source (Through + 1 .. Source'Last);
+ begin
+ return Result;
+ end;
+ end if;
+ end Delete;
+
+ procedure Delete
+ (Source : in out Wide_String;
+ From : in Positive;
+ Through : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ begin
+ Move (Source => Delete (Source, From, Through),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Delete;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : in Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Count);
+
+ begin
+ if Count <= Source'Length then
+ Result := Source (Source'First .. Source'First + Count - 1);
+
+ else
+ Result (1 .. Source'Length) := Source;
+
+ for J in Source'Length + 1 .. Count loop
+ Result (J) := Pad;
+ end loop;
+ end if;
+
+ return Result;
+ end Head;
+
+ procedure Head
+ (Source : in out Wide_String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space)
+ is
+ begin
+ Move (Source => Head (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Head;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : in Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Source'Length + New_Item'Length);
+
+ begin
+ if Before < Source'First or else Before > Source'Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Result := Source (Source'First .. Before - 1) & New_Item &
+ Source (Before .. Source'Last);
+ return Result;
+ end Insert;
+
+ procedure Insert
+ (Source : in out Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ is
+ begin
+ Move (Source => Insert (Source, Before, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Insert;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Source : in Wide_String;
+ Target : out Wide_String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ Sfirst : constant Integer := Source'First;
+ Slast : constant Integer := Source'Last;
+ Slength : constant Integer := Source'Length;
+
+ Tfirst : constant Integer := Target'First;
+ Tlast : constant Integer := Target'Last;
+ Tlength : constant Integer := Target'Length;
+
+ function Is_Padding (Item : Wide_String) return Boolean;
+ -- Determinbe if all characters in Item are pad characters
+
+ function Is_Padding (Item : Wide_String) return Boolean is
+ begin
+ for J in Item'Range loop
+ if Item (J) /= Pad then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Padding;
+
+ -- Start of processing for Move
+
+ begin
+ if Slength = Tlength then
+ Target := Source;
+
+ elsif Slength > Tlength then
+
+ case Drop is
+ when Left =>
+ Target := Source (Slast - Tlength + 1 .. Slast);
+
+ when Right =>
+ Target := Source (Sfirst .. Sfirst + Tlength - 1);
+
+ when Error =>
+ case Justify is
+ when Left =>
+ if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
+ Target :=
+ Source (Sfirst .. Sfirst + Target'Length - 1);
+ else
+ raise Length_Error;
+ end if;
+
+ when Right =>
+ if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
+ Target := Source (Slast - Tlength + 1 .. Slast);
+ else
+ raise Length_Error;
+ end if;
+
+ when Center =>
+ raise Length_Error;
+ end case;
+
+ end case;
+
+ -- Source'Length < Target'Length
+
+ else
+ case Justify is
+ when Left =>
+ Target (Tfirst .. Tfirst + Slength - 1) := Source;
+
+ for J in Tfirst + Slength .. Tlast loop
+ Target (J) := Pad;
+ end loop;
+
+ when Right =>
+ for J in Tfirst .. Tlast - Slength loop
+ Target (J) := Pad;
+ end loop;
+
+ Target (Tlast - Slength + 1 .. Tlast) := Source;
+
+ when Center =>
+ declare
+ Front_Pad : constant Integer := (Tlength - Slength) / 2;
+ Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
+
+ begin
+ for J in Tfirst .. Tfirst_Fpad - 1 loop
+ Target (J) := Pad;
+ end loop;
+
+ Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
+
+ for J in Tfirst_Fpad + Slength .. Tlast loop
+ Target (J) := Pad;
+ end loop;
+ end;
+ end case;
+ end if;
+ end Move;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : in Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String)
+ return Wide_String
+ is
+ begin
+ if Position not in Source'First .. Source'Last + 1 then
+ raise Index_Error;
+ else
+ declare
+ Result_Length : Natural :=
+ Natural'Max (Source'Length,
+ Position - Source'First + New_Item'Length);
+ Result : Wide_String (1 .. Result_Length);
+
+ begin
+ Result := Source (Source'First .. Position - 1) & New_Item &
+ Source (Position + New_Item'Length .. Source'Last);
+ return Result;
+ end;
+ end if;
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Right)
+ is
+ begin
+ Move (Source => Overwrite (Source, Position, New_Item),
+ Target => Source,
+ Drop => Drop);
+ end Overwrite;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : in Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String)
+ return Wide_String
+ is
+ Result_Length : Natural;
+
+ begin
+ if Low > Source'Last + 1 or else High < Source'First - 1 then
+ raise Index_Error;
+ else
+ Result_Length :=
+ Source'Length - Natural'Max (High - Low + 1, 0) + By'Length;
+
+ declare
+ Result : Wide_String (1 .. Result_Length);
+
+ begin
+ if High >= Low then
+ Result :=
+ Source (Source'First .. Low - 1) & By &
+ Source (High + 1 .. Source'Last);
+ else
+ Result := Source (Source'First .. Low - 1) & By &
+ Source (Low .. Source'Last);
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ begin
+ Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
+ end Replace_Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : in Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Count);
+
+ begin
+ if Count < Source'Length then
+ Result := Source (Source'Last - Count + 1 .. Source'Last);
+
+ -- Pad on left
+
+ else
+ for J in 1 .. Count - Source'Length loop
+ Result (J) := Pad;
+ end loop;
+
+ Result (Count - Source'Length + 1 .. Count) := Source;
+ end if;
+
+ return Result;
+ end Tail;
+
+ procedure Tail
+ (Source : in out Wide_String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space)
+ is
+ begin
+ Move (Source => Tail (Source, Count, Pad),
+ Target => Source,
+ Drop => Error,
+ Justify => Justify,
+ Pad => Pad);
+ end Tail;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Source'Length);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ is
+ begin
+ for J in Source'Range loop
+ Source (J) := Value (Mapping, Source (J));
+ end loop;
+ end Translate;
+
+ function Translate
+ (Source : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Wide_String
+ is
+ Result : Wide_String (1 .. Source'Length);
+
+ begin
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Mapping (Source (J));
+ end loop;
+
+ return Result;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ is
+ begin
+ for J in Source'Range loop
+ Source (J) := Mapping (Source (J));
+ end loop;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : in Wide_String;
+ Side : in Trim_End)
+ return Wide_String
+ is
+ Low : Natural := Source'First;
+ High : Natural := Source'Last;
+
+ begin
+ if Side = Left or else Side = Both then
+ while Low <= High and then Source (Low) = Wide_Space loop
+ Low := Low + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while High >= Low and then Source (High) = Wide_Space loop
+ High := High - 1;
+ end loop;
+ end if;
+
+ -- All blanks case
+
+ if Low > High then
+ return "";
+
+ -- At least one non-blank
+
+ else
+ declare
+ Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High);
+
+ begin
+ return Result;
+ end;
+ end if;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Wide_String;
+ Side : in Trim_End;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ begin
+ Move (Source => Trim (Source, Side),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+ function Trim
+ (Source : in Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Wide_String
+ is
+ Low : Natural := Source'First;
+ High : Natural := Source'Last;
+
+ begin
+ while Low <= High and then Is_In (Source (Low), Left) loop
+ Low := Low + 1;
+ end loop;
+
+ while High >= Low and then Is_In (Source (High), Right) loop
+ High := High - 1;
+ end loop;
+
+ -- Case where source comprises only characters in the sets
+
+ if Low > High then
+ return "";
+ else
+ declare
+ subtype WS is Wide_String (1 .. High - Low + 1);
+
+ begin
+ return WS (Source (Low .. High));
+ end;
+ end if;
+ end Trim;
+
+ procedure Trim
+ (Source : in out Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set;
+ Justify : in Alignment := Strings.Left;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ begin
+ Move (Source => Trim (Source, Left, Right),
+ Target => Source,
+ Justify => Justify,
+ Pad => Pad);
+ end Trim;
+
+end Ada.Strings.Wide_Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ F I X E D --
+-- --
+-- 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.Strings.Wide_Maps;
+
+package Ada.Strings.Wide_Fixed is
+pragma Preelaborate (Wide_Fixed);
+
+ -------------------------------------------------------------------
+ -- Copy Procedure for Wide_Strings of Possibly Different Lengths --
+ -------------------------------------------------------------------
+
+ procedure Move
+ (Source : in Wide_String;
+ Target : out Wide_String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in Wide_String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural;
+
+ procedure Find_Token
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ -----------------------------------------
+ -- Wide_String Translation Subprograms --
+ -----------------------------------------
+
+ function Translate
+ (Source : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Wide_String;
+
+ procedure Translate
+ (Source : in out Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping);
+
+ function Translate
+ (Source : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Wide_String;
+
+ procedure Translate
+ (Source : in out Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function);
+
+ --------------------------------------------
+ -- Wide_String Transformation Subprograms --
+ --------------------------------------------
+
+ function Replace_Slice
+ (Source : in Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String)
+ return Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ function Insert
+ (Source : in Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String)
+ return Wide_String;
+
+ procedure Insert
+ (Source : in out Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error);
+
+ function Overwrite
+ (Source : in Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String)
+ return Wide_String;
+
+ procedure Overwrite
+ (Source : in out Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Right);
+
+ function Delete
+ (Source : in Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Wide_String;
+
+ procedure Delete
+ (Source : in out Wide_String;
+ From : in Positive;
+ Through : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ --------------------------------------
+ -- Wide_String Selector Subprograms --
+ --------------------------------------
+
+ function Trim
+ (Source : in Wide_String;
+ Side : in Trim_End)
+ return Wide_String;
+
+ procedure Trim
+ (Source : in out Wide_String;
+ Side : in Trim_End;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Wide_Space);
+
+ function Trim
+ (Source : in Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Wide_String;
+
+ procedure Trim
+ (Source : in out Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set;
+ Justify : in Alignment := Ada.Strings.Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ function Head
+ (Source : in Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space)
+ return Wide_String;
+
+ procedure Head
+ (Source : in out Wide_String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ function Tail
+ (Source : in Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space)
+ return Wide_String;
+
+ procedure Tail
+ (Source : in out Wide_String;
+ Count : in Natural;
+ Justify : in Alignment := Left;
+ Pad : in Wide_Character := Ada.Strings.Wide_Space);
+
+ ---------------------------------------
+ -- Wide_String Constructor Functions --
+ ---------------------------------------
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_Character)
+ return Wide_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_String)
+ return Wide_String;
+
+end Ada.Strings.Wide_Fixed;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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_Deallocation;
+
+package body Ada.Strings.Wide_Maps is
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set
+ is
+ LS : constant Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ -- Each range on the right can generate at least one more range in
+ -- the result, by splitting one of the left operand ranges.
+
+ N : Natural := 0;
+ R : Natural := 1;
+ L : Natural := 1;
+
+ Left_Low : Wide_Character;
+ -- Left_Low is lowest character of the L'th range not yet dealt with
+
+ begin
+ if LS'Last = 0 or else RS'Last = 0 then
+ return Left;
+ end if;
+
+ Left_Low := LS (L).Low;
+ while R <= RS'Last loop
+
+ -- If next right range is below current left range, skip it
+
+ if RS (R).High < Left_Low then
+ R := R + 1;
+
+ -- If next right range above current left range, copy remainder
+ -- of the left range to the result
+
+ elsif RS (R).Low > LS (L).High then
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := LS (L).High;
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+
+ else
+ -- Next right range overlaps bottom of left range
+
+ if RS (R).Low <= Left_Low then
+
+ -- Case of right range complete overlaps left range
+
+ if RS (R).High >= LS (L).High then
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+
+ -- Case of right range eats lower part of left range
+
+ else
+ Left_Low := Wide_Character'Succ (RS (R).High);
+ R := R + 1;
+ end if;
+
+ -- Next right range overlaps some of left range, but not bottom
+
+ else
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := Wide_Character'Pred (RS (R).Low);
+
+ -- Case of right range splits left range
+
+ if RS (R).High < LS (L).High then
+ Left_Low := Wide_Character'Succ (RS (R).High);
+ R := R + 1;
+
+ -- Case of right range overlaps top of left range
+
+ else
+ L := L + 1;
+ exit when L > LS'Last;
+ Left_Low := LS (L).Low;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Copy remainder of left ranges to result
+
+ if L <= LS'Last then
+ N := N + 1;
+ Result (N).Low := Left_Low;
+ Result (N).High := LS (L).High;
+
+ loop
+ L := L + 1;
+ exit when L > LS'Last;
+ N := N + 1;
+ Result (N) := LS (L);
+ end loop;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(Result (1 .. N)));
+ end "-";
+
+ ---------
+ -- "=" --
+ ---------
+
+ -- The sorted, discontiguous form is canonical, so equality can be used
+
+ function "=" (Left, Right : in Wide_Character_Set) return Boolean is
+ begin
+ return Left.Set.all = Right.Set.all;
+ end "=";
+
+ -----------
+ -- "and" --
+ -----------
+
+ function "and"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set
+ is
+ LS : constant Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ N : Natural := 0;
+ L, R : Natural := 1;
+
+ begin
+ -- Loop to search for overlapping character ranges
+
+ while L <= LS'Last and then R <= RS'Last loop
+
+ if LS (L).High < RS (R).Low then
+ L := L + 1;
+
+ elsif RS (R).High < LS (L).Low then
+ R := R + 1;
+
+ -- Here we have LS (L).High >= RS (R).Low
+ -- and RS (R).High >= LS (L).Low
+ -- so we have an overlapping range
+
+ else
+ N := N + 1;
+ Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low);
+ Result (N).High :=
+ Wide_Character'Min (LS (L).High, RS (R).High);
+
+ if RS (R).High = LS (L).High then
+ L := L + 1;
+ R := R + 1;
+ elsif RS (R).High < LS (L).High then
+ R := R + 1;
+ else
+ L := L + 1;
+ end if;
+ end if;
+ end loop;
+
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(Result (1 .. N)));
+ end "and";
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not"
+ (Right : in Wide_Character_Set)
+ return Wide_Character_Set
+ is
+ RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Character_Ranges (1 .. RS'Last + 1);
+ N : Natural := 0;
+
+ begin
+ if RS'Last = 0 then
+ N := 1;
+ Result (1) := (Low => Wide_Character'First,
+ High => Wide_Character'Last);
+
+ else
+ if RS (1).Low /= Wide_Character'First then
+ N := N + 1;
+ Result (N).Low := Wide_Character'First;
+ Result (N).High := Wide_Character'Pred (RS (1).Low);
+ end if;
+
+ for K in 1 .. RS'Last - 1 loop
+ N := N + 1;
+ Result (N).Low := Wide_Character'Succ (RS (K).High);
+ Result (N).High := Wide_Character'Pred (RS (K + 1).Low);
+ end loop;
+
+ if RS (RS'Last).High /= Wide_Character'Last then
+ N := N + 1;
+ Result (N).Low := Wide_Character'Succ (RS (RS'Last).High);
+ Result (N).High := Wide_Character'Last;
+ end if;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(Result (1 .. N)));
+ end "not";
+
+ ----------
+ -- "or" --
+ ----------
+
+ function "or"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set
+ is
+ LS : constant Wide_Character_Ranges_Access := Left.Set;
+ RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+ Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+ N : Natural;
+ L, R : Natural;
+
+ begin
+ N := 0;
+ L := 1;
+ R := 1;
+
+ -- Loop through ranges in output file
+
+ loop
+ -- If no left ranges left, copy next right range
+
+ if L > LS'Last then
+ exit when R > RS'Last;
+ N := N + 1;
+ Result (N) := RS (R);
+ R := R + 1;
+
+ -- If no right ranges left, copy next left range
+
+ elsif R > RS'Last then
+ N := N + 1;
+ Result (N) := LS (L);
+ L := L + 1;
+
+ else
+ -- We have two ranges, choose lower one
+
+ N := N + 1;
+
+ if LS (L).Low <= RS (R).Low then
+ Result (N) := LS (L);
+ L := L + 1;
+ else
+ Result (N) := RS (R);
+ R := R + 1;
+ end if;
+
+ -- Loop to collapse ranges into last range
+
+ loop
+ -- Collapse next length range into current result range
+ -- if possible.
+
+ if L <= LS'Last
+ and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
+ then
+ Result (N).High :=
+ Wide_Character'Max (Result (N).High, LS (L).High);
+ L := L + 1;
+
+ -- Collapse next right range into current result range
+ -- if possible
+
+ elsif R <= RS'Last
+ and then RS (R).Low <=
+ Wide_Character'Succ (Result (N).High)
+ then
+ Result (N).High :=
+ Wide_Character'Max (Result (N).High, RS (R).High);
+ R := R + 1;
+
+ -- If neither range collapses, then done with this range
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(Result (1 .. N)));
+ end "or";
+
+ -----------
+ -- "xor" --
+ -----------
+
+ function "xor"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set
+ is
+ begin
+ return (Left or Right) - (Left and Right);
+ end "xor";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Wide_Character_Mapping) is
+ begin
+ Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all);
+ end Adjust;
+
+ procedure Adjust (Object : in out Wide_Character_Set) is
+ begin
+ Object.Set := new Wide_Character_Ranges'(Object.Set.all);
+ end Adjust;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Wide_Character_Mapping) is
+
+ procedure Free is new Unchecked_Deallocation
+ (Wide_Character_Mapping_Values,
+ Wide_Character_Mapping_Values_Access);
+
+ begin
+ if Object.Map /= Null_Map'Unrestricted_Access then
+ Free (Object.Map);
+ end if;
+ end Finalize;
+
+ procedure Finalize (Object : in out Wide_Character_Set) is
+
+ procedure Free is new Unchecked_Deallocation
+ (Wide_Character_Ranges,
+ Wide_Character_Ranges_Access);
+
+ begin
+ if Object.Set /= Null_Range'Unrestricted_Access then
+ Free (Object.Set);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Wide_Character_Mapping) is
+ begin
+ Object := Identity;
+ end Initialize;
+
+ procedure Initialize (Object : in out Wide_Character_Set) is
+ begin
+ Object := Null_Set;
+ end Initialize;
+
+ -----------
+ -- Is_In --
+ -----------
+
+ function Is_In
+ (Element : in Wide_Character;
+ Set : in Wide_Character_Set)
+ return Boolean
+ is
+ L, R, M : Natural;
+ SS : constant Wide_Character_Ranges_Access := Set.Set;
+
+ begin
+ L := 1;
+ R := SS'Last;
+
+ -- Binary search loop. The invariant is that if Element is in any of
+ -- of the constituent ranges it is in one between Set (L) and Set (R).
+
+ loop
+ if L > R then
+ return False;
+
+ else
+ M := (L + R) / 2;
+
+ if Element > SS (M).High then
+ L := M + 1;
+ elsif Element < SS (M).Low then
+ R := M - 1;
+ else
+ return True;
+ end if;
+ end if;
+ end loop;
+ end Is_In;
+
+ ---------------
+ -- Is_Subset --
+ ---------------
+
+ function Is_Subset
+ (Elements : in Wide_Character_Set;
+ Set : in Wide_Character_Set)
+ return Boolean
+ is
+ ES : constant Wide_Character_Ranges_Access := Elements.Set;
+ SS : constant Wide_Character_Ranges_Access := Set.Set;
+
+ S : Positive := 1;
+ E : Positive := 1;
+
+ begin
+ loop
+ -- If no more element ranges, done, and result is true
+
+ if E > ES'Last then
+ return True;
+
+ -- If more element ranges, but no more set ranges, result is false
+
+ elsif S > SS'Last then
+ return False;
+
+ -- Remove irrelevant set range
+
+ elsif SS (S).High < ES (E).Low then
+ S := S + 1;
+
+ -- Get rid of element range that is properly covered by set
+
+ elsif SS (S).Low <= ES (E).Low
+ and then ES (E).High <= SS (S).High
+ then
+ E := E + 1;
+
+ -- Otherwise we have a non-covered element range, result is false
+
+ else
+ return False;
+ end if;
+ end loop;
+ end Is_Subset;
+
+ ---------------
+ -- To_Domain --
+ ---------------
+
+ function To_Domain
+ (Map : in Wide_Character_Mapping)
+ return Wide_Character_Sequence
+ is
+ begin
+ return Map.Map.Domain;
+ end To_Domain;
+
+ ----------------
+ -- To_Mapping --
+ ----------------
+
+ function To_Mapping
+ (From, To : in Wide_Character_Sequence)
+ return Wide_Character_Mapping
+ is
+ Domain : Wide_Character_Sequence (1 .. From'Length);
+ Rangev : Wide_Character_Sequence (1 .. To'Length);
+ N : Natural := 0;
+
+ begin
+ if From'Length /= To'Length then
+ raise Translation_Error;
+
+ else
+ pragma Warnings (Off); -- apparent uninit use of Domain
+
+ for J in From'Range loop
+ for M in 1 .. N loop
+ if From (J) = Domain (M) then
+ raise Translation_Error;
+ elsif From (J) < Domain (M) then
+ Domain (M + 1 .. N + 1) := Domain (M .. N);
+ Rangev (M + 1 .. N + 1) := Rangev (M .. N);
+ Domain (M) := From (J);
+ Rangev (M) := To (J);
+ goto Continue;
+ end if;
+ end loop;
+
+ Domain (N + 1) := From (J);
+ Rangev (N + 1) := To (J);
+
+ <<Continue>>
+ N := N + 1;
+ end loop;
+
+ pragma Warnings (On);
+
+ return (AF.Controlled with
+ Map => new Wide_Character_Mapping_Values'(
+ Length => N,
+ Domain => Domain (1 .. N),
+ Rangev => Rangev (1 .. N)));
+ end if;
+ end To_Mapping;
+
+ --------------
+ -- To_Range --
+ --------------
+
+ function To_Range
+ (Map : in Wide_Character_Mapping)
+ return Wide_Character_Sequence
+ is
+ begin
+ return Map.Map.Rangev;
+ end To_Range;
+
+ ---------------
+ -- To_Ranges --
+ ---------------
+
+ function To_Ranges
+ (Set : in Wide_Character_Set)
+ return Wide_Character_Ranges
+ is
+ begin
+ return Set.Set.all;
+ end To_Ranges;
+
+ -----------------
+ -- To_Sequence --
+ -----------------
+
+ function To_Sequence
+ (Set : in Wide_Character_Set)
+ return Wide_Character_Sequence
+ is
+ SS : constant Wide_Character_Ranges_Access := Set.Set;
+
+ Result : Wide_String (Positive range 1 .. 2 ** 16);
+ N : Natural := 0;
+
+ begin
+ for J in SS'Range loop
+ for K in SS (J).Low .. SS (J).High loop
+ N := N + 1;
+ Result (N) := K;
+ end loop;
+ end loop;
+
+ return Result (1 .. N);
+ end To_Sequence;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ -- Case of multiple range input
+
+ function To_Set
+ (Ranges : in Wide_Character_Ranges)
+ return Wide_Character_Set
+ is
+ Result : Wide_Character_Ranges (Ranges'Range);
+ N : Natural := 0;
+ J : Natural;
+
+ begin
+ -- The output of To_Set is required to be sorted by increasing Low
+ -- values, and discontiguous, so first we sort them as we enter them,
+ -- using a simple insertion sort.
+
+ pragma Warnings (Off);
+ -- Kill bogus warning on Result being uninitialized
+
+ for J in Ranges'Range loop
+ for K in 1 .. N loop
+ if Ranges (J).Low < Result (K).Low then
+ Result (K + 1 .. N + 1) := Result (K .. N);
+ Result (K) := Ranges (J);
+ goto Continue;
+ end if;
+ end loop;
+
+ Result (N + 1) := Ranges (J);
+
+ <<Continue>>
+ N := N + 1;
+ end loop;
+
+ pragma Warnings (On);
+
+ -- Now collapse any contiguous or overlapping ranges
+
+ J := 1;
+ while J < N loop
+ if Result (J).High < Result (J).Low then
+ N := N - 1;
+ Result (J .. N) := Result (J + 1 .. N + 1);
+
+ elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then
+ Result (J).High :=
+ Wide_Character'Max (Result (J).High, Result (J + 1).High);
+
+ N := N - 1;
+ Result (J + 1 .. N) := Result (J + 2 .. N + 1);
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ if Result (N).High < Result (N).Low then
+ N := N - 1;
+ end if;
+
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(Result (1 .. N)));
+ end To_Set;
+
+ -- Case of single range input
+
+ function To_Set
+ (Span : in Wide_Character_Range)
+ return Wide_Character_Set
+ is
+ begin
+ if Span.Low > Span.High then
+ return Null_Set;
+ -- This is safe, because there is no procedure with parameter
+ -- Wide_Character_Set of mode "out" or "in out".
+
+ else
+ return (AF.Controlled with
+ Set => new Wide_Character_Ranges'(1 => Span));
+ end if;
+ end To_Set;
+
+ -- Case of wide string input
+
+ function To_Set
+ (Sequence : in Wide_Character_Sequence)
+ return Wide_Character_Set
+ is
+ R : Wide_Character_Ranges (1 .. Sequence'Length);
+
+ begin
+ for J in R'Range loop
+ R (J) := (Sequence (J), Sequence (J));
+ end loop;
+
+ return To_Set (R);
+ end To_Set;
+
+ -- Case of single wide character input
+
+ function To_Set
+ (Singleton : in Wide_Character)
+ return Wide_Character_Set
+ is
+ begin
+ return
+ (AF.Controlled with
+ Set => new Wide_Character_Ranges' (1 => (Singleton, Singleton)));
+ end To_Set;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (Map : in Wide_Character_Mapping;
+ Element : in Wide_Character)
+ return Wide_Character
+ is
+ L, R, M : Natural;
+
+ MV : constant Wide_Character_Mapping_Values_Access := Map.Map;
+
+ begin
+ L := 1;
+ R := MV.Domain'Last;
+
+ -- Binary search loop
+
+ loop
+ -- If not found, identity
+
+ if L > R then
+ return Element;
+
+ -- Otherwise do binary divide
+
+ else
+ M := (L + R) / 2;
+
+ if Element < MV.Domain (M) then
+ R := M - 1;
+
+ elsif Element > MV.Domain (M) then
+ L := M + 1;
+
+ else -- Element = MV.Domain (M) then
+ return MV.Rangev (M);
+ end if;
+ end if;
+ end loop;
+ end Value;
+
+end Ada.Strings.Wide_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ M A P S --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+
+package Ada.Strings.Wide_Maps is
+ pragma Preelaborate (Wide_Maps);
+
+ -------------------------------------
+ -- Wide Character Set Declarations --
+ -------------------------------------
+
+ type Wide_Character_Set is private;
+ -- Representation for a set of Wide_Character values:
+
+ Null_Set : constant Wide_Character_Set;
+
+ ------------------------------------------
+ -- Constructors for Wide Character Sets --
+ ------------------------------------------
+
+ type Wide_Character_Range is record
+ Low : Wide_Character;
+ High : Wide_Character;
+ end record;
+ -- Represents Wide_Character range Low .. High
+
+ type Wide_Character_Ranges is
+ array (Positive range <>) of Wide_Character_Range;
+
+ function To_Set
+ (Ranges : in Wide_Character_Ranges)
+ return Wide_Character_Set;
+
+ function To_Set
+ (Span : in Wide_Character_Range)
+ return Wide_Character_Set;
+
+ function To_Ranges
+ (Set : in Wide_Character_Set)
+ return Wide_Character_Ranges;
+
+ ---------------------------------------
+ -- Operations on Wide Character Sets --
+ ---------------------------------------
+
+ function "=" (Left, Right : in Wide_Character_Set) return Boolean;
+
+ function "not"
+ (Right : in Wide_Character_Set)
+ return Wide_Character_Set;
+
+ function "and"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set;
+
+ function "or"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set;
+
+ function "xor"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set;
+
+ function "-"
+ (Left, Right : in Wide_Character_Set)
+ return Wide_Character_Set;
+
+ function Is_In
+ (Element : in Wide_Character;
+ Set : in Wide_Character_Set)
+ return Boolean;
+
+ function Is_Subset
+ (Elements : in Wide_Character_Set;
+ Set : in Wide_Character_Set)
+ return Boolean;
+
+ function "<="
+ (Left : in Wide_Character_Set;
+ Right : in Wide_Character_Set)
+ return Boolean
+ renames Is_Subset;
+
+ subtype Wide_Character_Sequence is Wide_String;
+ -- Alternative representation for a set of character values
+
+ function To_Set
+ (Sequence : in Wide_Character_Sequence)
+ return Wide_Character_Set;
+
+ function To_Set
+ (Singleton : in Wide_Character)
+ return Wide_Character_Set;
+
+ function To_Sequence
+ (Set : in Wide_Character_Set)
+ return Wide_Character_Sequence;
+
+ -----------------------------------------
+ -- Wide Character Mapping Declarations --
+ -----------------------------------------
+
+ type Wide_Character_Mapping is private;
+ -- Representation for a wide character to wide character mapping:
+
+ function Value
+ (Map : in Wide_Character_Mapping;
+ Element : in Wide_Character)
+ return Wide_Character;
+
+ Identity : constant Wide_Character_Mapping;
+
+ ---------------------------------
+ -- Operations on Wide Mappings --
+ ---------------------------------
+
+ function To_Mapping
+ (From, To : in Wide_Character_Sequence)
+ return Wide_Character_Mapping;
+
+ function To_Domain
+ (Map : in Wide_Character_Mapping)
+ return Wide_Character_Sequence;
+
+ function To_Range
+ (Map : in Wide_Character_Mapping)
+ return Wide_Character_Sequence;
+
+ type Wide_Character_Mapping_Function is
+ access function (From : in Wide_Character) return Wide_Character;
+
+private
+ package AF renames Ada.Finalization;
+
+ ------------------------------------------
+ -- Representation of Wide_Character_Set --
+ ------------------------------------------
+
+ -- A wide character set is represented as a sequence of wide character
+ -- ranges (i.e. an object of type Wide_Character_Ranges) in which the
+ -- following hold:
+
+ -- The lower bound is 1
+ -- The ranges are in order by increasing Low values
+ -- The ranges are non-overlapping and discontigous
+
+ -- A character value is in the set if it is contained in one of the
+ -- ranges. The actual Wide_Character_Set value is a controlled pointer
+ -- to this Wide_Character_Ranges value. The use of a controlled type
+ -- is necessary to prevent storage leaks.
+
+ type Wide_Character_Ranges_Access is access all Wide_Character_Ranges;
+
+ type Wide_Character_Set is new AF.Controlled with record
+ Set : Wide_Character_Ranges_Access;
+ end record;
+
+ pragma Finalize_Storage_Only (Wide_Character_Set);
+ -- This avoids useless finalizations, and, more importantly avoids
+ -- incorrect attempts to finalize constants that are statically
+ -- declared here and in Ada.Strings.Wide_Maps, which is incorrect.
+
+ procedure Initialize (Object : in out Wide_Character_Set);
+ procedure Adjust (Object : in out Wide_Character_Set);
+ procedure Finalize (Object : in out Wide_Character_Set);
+
+ Null_Range : aliased constant Wide_Character_Ranges :=
+ (1 .. 0 => (Low => ' ', High => ' '));
+
+ Null_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Set => Null_Range'Unrestricted_Access);
+
+ ----------------------------------------------
+ -- Representation of Wide_Character_Mapping --
+ ----------------------------------------------
+
+ -- A wide character mapping is represented as two strings of equal
+ -- length, where any character appearing in Domain is mapped to the
+ -- corresponding character in Rangev. A character not appearing in
+ -- Domain is mapped to itself. The characters in Domain are sorted
+ -- in ascending order.
+
+ -- The actual Wide_Character_Mapping value is a controlled record
+ -- that contains a pointer to a discriminated record containing the
+ -- range and domain values.
+
+ -- Note: this representation is canonical, and the values stored in
+ -- Domain and Rangev are exactly the values that are returned by the
+ -- functions To_Domain and To_Range. The use of a controlled type is
+ -- necessary to prevent storage leaks.
+
+ type Wide_Character_Mapping_Values (Length : Natural) is record
+ Domain : Wide_Character_Sequence (1 .. Length);
+ Rangev : Wide_Character_Sequence (1 .. Length);
+ end record;
+
+ type Wide_Character_Mapping_Values_Access is
+ access all Wide_Character_Mapping_Values;
+
+ type Wide_Character_Mapping is new AF.Controlled with record
+ Map : Wide_Character_Mapping_Values_Access;
+ end record;
+
+ pragma Finalize_Storage_Only (Wide_Character_Mapping);
+ -- This avoids useless finalizations, and, more importantly avoids
+ -- incorrect attempts to finalize constants that are statically
+ -- declared here and in Ada.Strings.Wide_Maps, which is incorrect.
+
+ procedure Initialize (Object : in out Wide_Character_Mapping);
+ procedure Adjust (Object : in out Wide_Character_Mapping);
+ procedure Finalize (Object : in out Wide_Character_Mapping);
+
+ Null_Map : aliased constant Wide_Character_Mapping_Values :=
+ (Length => 0,
+ Domain => "",
+ Rangev => "");
+
+ Identity : constant Wide_Character_Mapping :=
+ (AF.Controlled with
+ Map => Null_Map'Unrestricted_Access);
+
+end Ada.Strings.Wide_Maps;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ S E A R C H --
+-- --
+-- 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 Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
+
+package body Ada.Strings.Wide_Search is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Belongs
+ (Element : Wide_Character;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership)
+ return Boolean;
+ pragma Inline (Belongs);
+ -- Determines if the given element is in (Test = Inside) or not in
+ -- (Test = Outside) the given character set.
+
+ -------------
+ -- Belongs --
+ -------------
+
+ function Belongs
+ (Element : Wide_Character;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership)
+ return Boolean is
+
+ begin
+ if Test = Inside then
+ return Is_In (Element, Set);
+ else
+ return not Is_In (Element, Set);
+ end if;
+ end Belongs;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ N : Natural;
+ J : Natural;
+
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- Handle the case of non-identity mappings by creating a mapped
+ -- string and making a recursive call using the identity mapping
+ -- on this mapped string.
+
+ if Mapping /= Wide_Maps.Identity then
+ declare
+ Mapped_Source : Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ return Count (Mapped_Source, Pattern);
+ end;
+ end if;
+
+ N := 0;
+ J := Source'First;
+
+ while J <= Source'Last - (Pattern'Length - 1) loop
+ if Source (J .. J + (Pattern'Length - 1)) = Pattern then
+ N := N + 1;
+ J := J + Pattern'Length;
+ else
+ J := J + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ function Count
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping (Source (J));
+ end loop;
+
+ return Count (Mapped_Source, Pattern);
+ end Count;
+
+ function Count (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural
+ is
+ N : Natural := 0;
+
+ begin
+ for J in Source'Range loop
+ if Is_In (Source (J), Set) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ return N;
+ end Count;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ First := J;
+
+ for K in J + 1 .. Source'Last loop
+ if not Belongs (Source (K), Set, Test) then
+ Last := K - 1;
+ return;
+ end if;
+ end loop;
+
+ -- Here if J indexes 1st char of token, and all chars
+ -- after J are in the token
+
+ Last := Source'Last;
+ return;
+ end if;
+ end loop;
+
+ -- Here if no token found
+
+ First := Source'First;
+ Last := 0;
+ end Find_Token;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ if Pattern = "" then
+ raise Pattern_Error;
+ end if;
+
+ -- Handle the case of non-identity mappings by creating a mapped
+ -- string and making a recursive call using the identity mapping
+ -- on this mapped string.
+
+ if Mapping /= Identity then
+ declare
+ Mapped_Source : Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Value (Mapping, Source (J));
+ end loop;
+
+ return Index (Mapped_Source, Pattern, Going);
+ end;
+ end if;
+
+ if Going = Forward then
+ for J in Source'First .. Source'Last - Pattern'Length + 1 loop
+ if Pattern = Source (J .. J + Pattern'Length - 1) then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'First .. Source'Last - Pattern'Length + 1 loop
+ if Pattern = Source (J .. J + Pattern'Length - 1) then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match found. Note that the loops are skipped
+ -- completely in the case of the pattern being longer than the source.
+
+ return 0;
+ end Index;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ Mapped_Source : Wide_String (Source'Range);
+
+ begin
+ for J in Source'Range loop
+ Mapped_Source (J) := Mapping (Source (J));
+ end loop;
+
+ return Index (Mapped_Source, Pattern, Going);
+ end Index;
+
+ function Index
+ (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ is
+ begin
+ if Going = Forward then
+ for J in Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'Range loop
+ if Belongs (Source (J), Set, Test) then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : in Wide_String;
+ Going : in Direction := Forward)
+ return Natural
+ is
+ begin
+ if Going = Forward then
+ for J in Source'Range loop
+ if Source (J) /= Wide_Space then
+ return J;
+ end if;
+ end loop;
+
+ else -- Going = Backward
+ for J in reverse Source'Range loop
+ if Source (J) /= Wide_Space then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through if no match
+
+ return 0;
+
+ end Index_Non_Blank;
+
+end Ada.Strings.Wide_Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ S E A R C H --
+-- --
+-- S p e c --
+-- --
+-- $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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the search functions from Ada.Strings.Wide_Fixed.
+-- They are separated out because they are shared by Ada.Strings.Wide_Bounded
+-- and Ada.Strings.Wide_Unbounded, and we don't want to drag other irrelevant
+-- stuff from Ada.Strings.Wide_Fixed when using the other two packages. We
+-- make this a private package, since user programs should access these
+-- subprograms via one of the standard string packages.
+
+with Ada.Strings.Wide_Maps;
+
+private package Ada.Strings.Wide_Search is
+pragma Preelaborate (Wide_Search);
+
+ function Index (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping :=
+ Wide_Maps.Identity)
+ return Natural;
+
+ function Index (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank (Source : in Wide_String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping :=
+ Wide_Maps.Identity)
+ return Natural;
+
+ function Count (Source : in Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural;
+
+
+ procedure Find_Token (Source : in Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+end Ada.Strings.Wide_Search;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Fixed;
+with Ada.Strings.Wide_Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Unbounded is
+
+ use Ada.Finalization;
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
+ return Unbounded_Wide_String
+ is
+ L_Length : constant Integer := Left.Reference.all'Length;
+ R_Length : constant Integer := Right.Reference.all'Length;
+ Length : constant Integer := L_Length + R_Length;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ Result.Reference.all (1 .. L_Length) := Left.Reference.all;
+ Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
+ return Unbounded_Wide_String
+ is
+ L_Length : constant Integer := Left.Reference.all'Length;
+ Length : constant Integer := L_Length + Right'Length;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ Result.Reference.all (1 .. L_Length) := Left.Reference.all;
+ Result.Reference.all (L_Length + 1 .. Length) := Right;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
+ return Unbounded_Wide_String
+ is
+ R_Length : constant Integer := Right.Reference.all'Length;
+ Length : constant Integer := Left'Length + R_Length;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ Result.Reference.all (1 .. Left'Length) := Left;
+ Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_Character)
+ return Unbounded_Wide_String
+ is
+ Length : constant Integer := Left.Reference.all'Length + 1;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ Result.Reference.all (1 .. Length - 1) := Left.Reference.all;
+ Result.Reference.all (Length) := Right;
+ return Result;
+ end "&";
+
+ function "&"
+ (Left : Wide_Character;
+ Right : Unbounded_Wide_String)
+ return Unbounded_Wide_String
+ is
+ Length : constant Integer := Right.Reference.all'Length + 1;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ Result.Reference.all (1) := Left;
+ Result.Reference.all (2 .. Length) := Right.Reference.all;
+ return Result;
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Character)
+ return Unbounded_Wide_String
+ is
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Left);
+ for J in Result.Reference'Range loop
+ Result.Reference (J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_String)
+ return Unbounded_Wide_String
+ is
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Left * Right'Length);
+
+ for J in 1 .. Left loop
+ Result.Reference.all
+ (Right'Length * J - Right'Length + 1 .. Right'Length * J) := Right;
+ end loop;
+
+ return Result;
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_String)
+ return Unbounded_Wide_String
+ is
+ R_Length : constant Integer := Right.Reference.all'Length;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Left * R_Length);
+
+ for I in 1 .. Left loop
+ Result.Reference.all (R_Length * I - R_Length + 1 .. R_Length * I) :=
+ Right.Reference.all;
+ end loop;
+
+ return Result;
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all < Right.Reference.all;
+ end "<";
+
+ function "<"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all < Right;
+ end "<";
+
+ function "<"
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Reference.all;
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all <= Right.Reference.all;
+ end "<=";
+
+ function "<="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all <= Right;
+ end "<=";
+
+ function "<="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Reference.all;
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all = Right.Reference.all;
+ end "=";
+
+ function "="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all = Right;
+ end "=";
+
+ function "="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left = Right.Reference.all;
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all > Right.Reference.all;
+ end ">";
+
+ function ">"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all > Right;
+ end ">";
+
+ function ">"
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Reference.all;
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all >= Right.Reference.all;
+ end ">=";
+
+ function ">="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Reference.all >= Right;
+ end ">=";
+
+ function ">="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Reference.all;
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_Wide_String) is
+ begin
+ -- Copy string, except we do not copy the statically allocated
+ -- null string, since it can never be deallocated.
+
+ if Object.Reference /= Null_Wide_String'Access then
+ Object.Reference := new Wide_String'(Object.Reference.all);
+ end if;
+ end Adjust;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Unbounded_Wide_String)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + New_Item.Reference.all'Length;
+ Temp : Wide_String_Access := Source.Reference;
+
+ begin
+ if Source.Reference = Null_Wide_String'Access then
+ Source := To_Unbounded_Wide_String (New_Item.Reference.all);
+ return;
+ end if;
+
+ Source.Reference := new Wide_String (1 .. Length);
+
+ Source.Reference.all (1 .. S_Length) := Temp.all;
+ Source.Reference.all (S_Length + 1 .. Length) := New_Item.Reference.all;
+ Free (Temp);
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Wide_String)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + New_Item'Length;
+ Temp : Wide_String_Access := Source.Reference;
+
+ begin
+ if Source.Reference = Null_Wide_String'Access then
+ Source := To_Unbounded_Wide_String (New_Item);
+ return;
+ end if;
+
+ Source.Reference := new Wide_String (1 .. Length);
+ Source.Reference.all (1 .. S_Length) := Temp.all;
+ Source.Reference.all (S_Length + 1 .. Length) := New_Item;
+ Free (Temp);
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Wide_Character)
+ is
+ S_Length : constant Integer := Source.Reference.all'Length;
+ Length : constant Integer := S_Length + 1;
+ Temp : Wide_String_Access := Source.Reference;
+
+ begin
+ if Source.Reference = Null_Wide_String'Access then
+ Source := To_Unbounded_Wide_String ("" & New_Item);
+ return;
+ end if;
+
+ Source.Reference := new Wide_String (1 .. Length);
+ Source.Reference.all (1 .. S_Length) := Temp.all;
+ Source.Reference.all (S_Length + 1) := New_Item;
+ Free (Temp);
+ end Append;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping :=
+ Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return Wide_Search.Count (Source.Reference.all, Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Search.Count (Source.Reference.all, Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set)
+ return Natural
+ is
+ begin
+ return Wide_Search.Count (Source.Reference.all, Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_Wide_String;
+ From : Positive;
+ Through : Natural)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Delete (Source.Reference.all, From, Through));
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ is
+ Temp : Wide_String_Access := Source.Reference;
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Delete (Temp.all, From, Through));
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_Wide_String;
+ Index : Positive)
+ return Wide_Character
+ is
+ begin
+ if Index <= Source.Reference.all'Last then
+ return Source.Reference.all (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_Wide_String) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
+
+ begin
+ -- Note: Don't try to free statically allocated null string
+
+ if Object.Reference /= Null_Wide_String'Access then
+ Deallocate (Object.Reference);
+ Object.Reference := Null_Unbounded_Wide_String.Reference;
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Wide_Search.Find_Token (Source.Reference.all, Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Wide_String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
+ begin
+ Deallocate (X);
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Head (Source.Reference.all, Count, Pad));
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Head (Source.Reference.all, Count, Pad));
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping :=
+ Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index (Source.Reference.all, Set, Test, Going);
+ end Index;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_String;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index_Non_Blank (Source.Reference.all, Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_Wide_String) is
+ begin
+ Object.Reference := Null_Unbounded_Wide_String.Reference;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_Wide_String;
+ Before : Positive;
+ New_Item : Wide_String)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item));
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String)
+ is
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item));
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_Wide_String) return Natural is
+ begin
+ return Source.Reference.all'Length;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_Wide_String;
+ Position : Positive;
+ New_Item : Wide_String)
+ return Unbounded_Wide_String is
+
+ begin
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Overwrite (Source.Reference.all, Position, New_Item));
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String)
+ is
+ Temp : Wide_String_Access := Source.Reference;
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Overwrite (Temp.all, Position, New_Item));
+ end Overwrite;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_String;
+ Index : Positive;
+ By : Wide_Character)
+ is
+ begin
+ if Index <= Source.Reference.all'Last then
+ Source.Reference.all (Index) := By;
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Replace_Slice (Source.Reference.all, Low, High, By));
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String)
+ is
+ Temp : Wide_String_Access := Source.Reference;
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Replace_Slice (Temp.all, Low, High, By));
+ end Replace_Slice;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural)
+ return Wide_String
+ is
+ Length : constant Natural := Source.Reference'Length;
+
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Length + 1 or else High > Length then
+ raise Index_Error;
+
+ else
+ declare
+ Result : Wide_String (1 .. High - Low + 1);
+
+ begin
+ Result := Source.Reference.all (Low .. High);
+ return Result;
+ end;
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
+ return Unbounded_Wide_String is
+
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Tail (Source.Reference.all, Count, Pad));
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ is
+ Temp : Wide_String_Access := Source.Reference;
+
+ begin
+ Source := To_Unbounded_Wide_String
+ (Wide_Fixed.Tail (Temp.all, Count, Pad));
+ end Tail;
+
+ ------------------------------
+ -- To_Unbounded_Wide_String --
+ ------------------------------
+
+ function To_Unbounded_Wide_String
+ (Source : Wide_String)
+ return Unbounded_Wide_String
+ is
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Source'Length);
+ Result.Reference.all := Source;
+ return Result;
+ end To_Unbounded_Wide_String;
+
+ function To_Unbounded_Wide_String (Length : in Natural)
+ return Unbounded_Wide_String
+ is
+ Result : Unbounded_Wide_String;
+
+ begin
+ Result.Reference := new Wide_String (1 .. Length);
+ return Result;
+ end To_Unbounded_Wide_String;
+
+ --------------------
+ -- To_Wide_String --
+ --------------------
+
+ function To_Wide_String
+ (Source : Unbounded_Wide_String)
+ return Wide_String
+ is
+ begin
+ return Source.Reference.all;
+ end To_Wide_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Translate (Source.Reference.all, Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ is
+ begin
+ Wide_Fixed.Translate (Source.Reference.all, Mapping);
+ end Translate;
+
+ function Translate
+ (Source : in Unbounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Translate (Source.Reference.all, Mapping));
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ is
+ begin
+ Wide_Fixed.Translate (Source.Reference.all, Mapping);
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : in Unbounded_Wide_String;
+ Side : in Trim_End)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Trim (Source.Reference.all, Side));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Side : in Trim_End)
+ is
+ Old : Wide_String_Access := Source.Reference;
+ begin
+ Source.Reference := new Wide_String'(Wide_Fixed.Trim (Old.all, Side));
+ Free (Old);
+ end Trim;
+
+ function Trim
+ (Source : in Unbounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Unbounded_Wide_String
+ is
+ begin
+ return
+ To_Unbounded_Wide_String
+ (Wide_Fixed.Trim (Source.Reference.all, Left, Right));
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ is
+ Old : Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference :=
+ new Wide_String'(Wide_Fixed.Trim (Old.all, Left, Right));
+ Free (Old);
+ end Trim;
+
+end Ada.Strings.Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- 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.Wide_Maps;
+with Ada.Finalization;
+
+package Ada.Strings.Wide_Unbounded is
+pragma Preelaborate (Wide_Unbounded);
+
+ type Unbounded_Wide_String is private;
+
+ Null_Unbounded_Wide_String : constant Unbounded_Wide_String;
+
+ function Length (Source : Unbounded_Wide_String) return Natural;
+
+ type Wide_String_Access is access all Wide_String;
+
+ procedure Free (X : in out Wide_String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_Wide_String
+ (Source : Wide_String)
+ return Unbounded_Wide_String;
+
+ function To_Unbounded_Wide_String
+ (Length : in Natural)
+ return Unbounded_Wide_String;
+
+ function To_Wide_String
+ (Source : Unbounded_Wide_String)
+ return Wide_String;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Unbounded_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : in Wide_Character);
+
+ function "&"
+ (Left, Right : Unbounded_Wide_String)
+ return Unbounded_Wide_String;
+
+ function "&"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Unbounded_Wide_String;
+
+ function "&"
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Unbounded_Wide_String;
+
+ function "&"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_Character)
+ return Unbounded_Wide_String;
+
+ function "&"
+ (Left : in Wide_Character;
+ Right : in Unbounded_Wide_String)
+ return Unbounded_Wide_String;
+
+ function Element
+ (Source : in Unbounded_Wide_String;
+ Index : in Positive)
+ return Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_String;
+ Index : in Positive;
+ By : Wide_Character);
+
+ function Slice
+ (Source : in Unbounded_Wide_String;
+ Low : in Positive;
+ High : in Natural)
+ return Wide_String;
+
+ function "="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function "="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "<"
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function "<="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function ">"
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Unbounded_Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Unbounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean;
+
+ function ">="
+ (Left : in Wide_String;
+ Right : in Unbounded_Wide_String)
+ return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : in Unbounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Index_Non_Blank
+ (Source : in Unbounded_Wide_String;
+ Going : in Direction := Forward)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : in Unbounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural;
+
+ procedure Find_Token
+ (Source : in Unbounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- Wide_String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : in Unbounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Unbounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping);
+
+ function Translate
+ (Source : in Unbounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Unbounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- Wide_String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : in Unbounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String)
+ return Unbounded_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String);
+
+ function Insert
+ (Source : in Unbounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String)
+ return Unbounded_Wide_String;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String);
+
+ function Overwrite
+ (Source : in Unbounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String)
+ return Unbounded_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String);
+
+ function Delete
+ (Source : in Unbounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Unbounded_Wide_String;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_String;
+ From : in Positive;
+ Through : in Natural);
+
+ function Trim
+ (Source : in Unbounded_Wide_String;
+ Side : in Trim_End)
+ return Unbounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Side : in Trim_End);
+
+ function Trim
+ (Source : in Unbounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Unbounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set);
+
+ function Head
+ (Source : in Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ return Unbounded_Wide_String;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space);
+
+ function Tail
+ (Source : in Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space)
+ return Unbounded_Wide_String;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space);
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_Character)
+ return Unbounded_Wide_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Wide_String)
+ return Unbounded_Wide_String;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Unbounded_Wide_String)
+ return Unbounded_Wide_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ Null_Wide_String : aliased Wide_String := "";
+
+ function To_Unbounded_Wide (S : Wide_String) return Unbounded_Wide_String
+ renames To_Unbounded_Wide_String;
+
+ type Unbounded_Wide_String is new AF.Controlled with record
+ Reference : Wide_String_Access := Null_Wide_String'Access;
+ end record;
+
+ pragma Stream_Convert
+ (Unbounded_Wide_String, To_Unbounded_Wide, To_Wide_String);
+
+ pragma Finalize_Storage_Only (Unbounded_Wide_String);
+
+ procedure Initialize (Object : in out Unbounded_Wide_String);
+ procedure Adjust (Object : in out Unbounded_Wide_String);
+ procedure Finalize (Object : in out Unbounded_Wide_String);
+
+ Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
+ (AF.Controlled with Reference => Null_Wide_String'Access);
+
+end Ada.Strings.Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1997-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.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Ada.Strings.Unbounded.Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_String is
+ Buffer : String (1 .. 1000);
+ Last : Natural;
+ Str1 : String_Access;
+ Str2 : String_Access;
+ Result : Unbounded_String;
+
+ begin
+ Get_Line (Buffer, Last);
+ Str1 := new String'(Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Str2 := new String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_String (Result, Str1);
+ return Result;
+ end Get_Line;
+
+ function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is
+ Buffer : String (1 .. 1000);
+ Last : Natural;
+ Str1 : String_Access;
+ Str2 : String_Access;
+ Result : Unbounded_String;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Str1 := new String'(Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Str2 := new String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ Set_String (Result, Str1);
+ return Result;
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_String) is
+ begin
+ Put (Get_String (U).all);
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_String) is
+ begin
+ Put (File, Get_String (U).all);
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_String) is
+ begin
+ Put_Line (Get_String (U).all);
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_String) is
+ begin
+ Put_Line (File, Get_String (U).all);
+ end Put_Line;
+
+end Ada.Strings.Unbounded.Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1997-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 child package of Ada.Strings.Unbounded provides some specialized
+-- Text_IO routines that work directly with unbounded strings, avoiding the
+-- inefficiencies of access via the standard interface, and also taking
+-- direct advantage of the variable length semantics of these strings.
+
+with Ada.Text_IO;
+
+package Ada.Strings.Unbounded.Text_IO is
+
+ function Get_Line return Unbounded_String;
+ function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String;
+ -- Reads up to the end of the current line, returning the result
+ -- as an unbounded string of appropriate length. If no File parameter
+ -- is present, input is from Current_Input.
+
+ procedure Put (U : Unbounded_String);
+ procedure Put (File : Ada.Text_IO.File_Type; U : Unbounded_String);
+ procedure Put_Line (U : Unbounded_String);
+ procedure Put_Line (File : Ada.Text_IO.File_Type; U : Unbounded_String);
+ -- These are equivalent to the standard Text_IO routines passed the
+ -- value To_String (U), but operate more efficiently, because the extra
+ -- copy of the argument is avoided.
+
+end Ada.Strings.Unbounded.Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ M A P S . W I D E _ C O N S T A N T S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- 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.Wide_Latin_1;
+
+package Ada.Strings.Wide_Maps.Wide_Constants is
+pragma Preelaborate (Wide_Constants);
+
+ Control_Set : constant Wide_Maps.Wide_Character_Set;
+ Graphic_Set : constant Wide_Maps.Wide_Character_Set;
+ Letter_Set : constant Wide_Maps.Wide_Character_Set;
+ Lower_Set : constant Wide_Maps.Wide_Character_Set;
+ Upper_Set : constant Wide_Maps.Wide_Character_Set;
+ Basic_Set : constant Wide_Maps.Wide_Character_Set;
+ Decimal_Digit_Set : constant Wide_Maps.Wide_Character_Set;
+ Hexadecimal_Digit_Set : constant Wide_Maps.Wide_Character_Set;
+ Alphanumeric_Set : constant Wide_Maps.Wide_Character_Set;
+ Special_Graphic_Set : constant Wide_Maps.Wide_Character_Set;
+ ISO_646_Set : constant Wide_Maps.Wide_Character_Set;
+ Character_Set : constant Wide_Maps.Wide_Character_Set;
+
+ Lower_Case_Map : constant Wide_Maps.Wide_Character_Mapping;
+ -- Maps to lower case for letters, else identity
+
+ Upper_Case_Map : constant Wide_Maps.Wide_Character_Mapping;
+ -- Maps to upper case for letters, else identity
+
+ Basic_Map : constant Wide_Maps.Wide_Character_Mapping;
+ -- Maps to basic letter for letters, else identity
+
+private
+ package W renames Ada.Characters.Wide_Latin_1;
+
+ subtype WC is Wide_Character;
+
+ Control_Ranges : aliased constant Wide_Character_Ranges :=
+ ((W.NUL, W.US),
+ (W.DEL, W.APC));
+
+ Control_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Control_Ranges'Unrestricted_Access);
+
+ Graphic_Ranges : aliased constant Wide_Character_Ranges :=
+ ((W.Space, W.Tilde),
+ (WC'Val (256), WC'Last));
+
+ Graphic_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Graphic_Ranges'Unrestricted_Access);
+
+ Letter_Ranges : aliased constant Wide_Character_Ranges :=
+ (('A', 'Z'),
+ (W.LC_A, W.LC_Z),
+ (W.UC_A_Grave, W.UC_O_Diaeresis),
+ (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis),
+ (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Letter_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Letter_Ranges'Unrestricted_Access);
+
+ Lower_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => (W.LC_A, W.LC_Z),
+ 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis),
+ 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Lower_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Lower_Ranges'Unrestricted_Access);
+
+ Upper_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => ('A', 'Z'),
+ 2 => (W.UC_A_Grave, W.UC_O_Diaeresis),
+ 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn));
+
+ Upper_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Upper_Ranges'Unrestricted_Access);
+
+ Basic_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => ('A', 'Z'),
+ 2 => (W.LC_A, W.LC_Z),
+ 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong),
+ 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong),
+ 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S),
+ 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn),
+ 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn),
+ 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth),
+ 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth));
+
+ Basic_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Basic_Ranges'Unrestricted_Access);
+
+ Decimal_Digit_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => ('0', '9'));
+
+ Decimal_Digit_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Decimal_Digit_Ranges'Unrestricted_Access);
+
+ Hexadecimal_Digit_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => ('0', '9'),
+ 2 => ('A', 'F'),
+ 3 => (W.LC_A, W.LC_F));
+
+ Hexadecimal_Digit_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Hexadecimal_Digit_Ranges'Unrestricted_Access);
+
+ Alphanumeric_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => ('0', '9'),
+ 2 => ('A', 'Z'),
+ 3 => (W.LC_A, W.LC_Z),
+ 4 => (W.UC_A_Grave, W.UC_O_Diaeresis),
+ 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis),
+ 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis));
+
+ Alphanumeric_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Alphanumeric_Ranges'Unrestricted_Access);
+
+ Special_Graphic_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => (Wide_Space, W.Solidus),
+ 2 => (W.Colon, W.Commercial_At),
+ 3 => (W.Left_Square_Bracket, W.Grave),
+ 4 => (W.Left_Curly_Bracket, W.Tilde),
+ 5 => (W.No_Break_Space, W.Inverted_Question),
+ 6 => (W.Multiplication_Sign, W.Multiplication_Sign),
+ 7 => (W.Division_Sign, W.Division_Sign));
+
+ Special_Graphic_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Special_Graphic_Ranges'Unrestricted_Access);
+
+ ISO_646_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => (W.NUL, W.DEL));
+
+ ISO_646_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ ISO_646_Ranges'Unrestricted_Access);
+
+ Character_Ranges : aliased constant Wide_Character_Ranges :=
+ (1 => (W.NUL, WC'Val (255)));
+
+ Character_Set : constant Wide_Character_Set :=
+ (AF.Controlled with
+ Character_Ranges'Unrestricted_Access);
+
+
+ Lower_Case_Mapping : aliased constant Wide_Character_Mapping_Values :=
+ (Length => 56,
+
+ Domain =>
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_AE_Diphthong &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_Icelandic_Eth &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.UC_Icelandic_Thorn,
+
+ Rangev =>
+ "abcdefghijklmnopqrstuvwxyz" &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_AE_Diphthong &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_Icelandic_Eth &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Icelandic_Thorn);
+
+ Lower_Case_Map : constant Wide_Character_Mapping :=
+ (AF.Controlled with
+ Map => Lower_Case_Mapping'Unrestricted_Access);
+
+ Upper_Case_Mapping : aliased constant Wide_Character_Mapping_Values :=
+ (Length => 56,
+
+ Domain =>
+ "abcdefghijklmnopqrstuvwxyz" &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_AE_Diphthong &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_Icelandic_Eth &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Icelandic_Thorn,
+
+ Rangev =>
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_AE_Diphthong &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_Icelandic_Eth &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.UC_Icelandic_Thorn);
+
+ Upper_Case_Map : constant Wide_Character_Mapping :=
+ (AF.Controlled with
+ Upper_Case_Mapping'Unrestricted_Access);
+
+ Basic_Mapping : aliased constant Wide_Character_Mapping_Values :=
+ (Length => 55,
+
+ Domain =>
+ W.UC_A_Grave &
+ W.UC_A_Acute &
+ W.UC_A_Circumflex &
+ W.UC_A_Tilde &
+ W.UC_A_Diaeresis &
+ W.UC_A_Ring &
+ W.UC_C_Cedilla &
+ W.UC_E_Grave &
+ W.UC_E_Acute &
+ W.UC_E_Circumflex &
+ W.UC_E_Diaeresis &
+ W.UC_I_Grave &
+ W.UC_I_Acute &
+ W.UC_I_Circumflex &
+ W.UC_I_Diaeresis &
+ W.UC_N_Tilde &
+ W.UC_O_Grave &
+ W.UC_O_Acute &
+ W.UC_O_Circumflex &
+ W.UC_O_Tilde &
+ W.UC_O_Diaeresis &
+ W.UC_O_Oblique_Stroke &
+ W.UC_U_Grave &
+ W.UC_U_Acute &
+ W.UC_U_Circumflex &
+ W.UC_U_Diaeresis &
+ W.UC_Y_Acute &
+ W.LC_A_Grave &
+ W.LC_A_Acute &
+ W.LC_A_Circumflex &
+ W.LC_A_Tilde &
+ W.LC_A_Diaeresis &
+ W.LC_A_Ring &
+ W.LC_C_Cedilla &
+ W.LC_E_Grave &
+ W.LC_E_Acute &
+ W.LC_E_Circumflex &
+ W.LC_E_Diaeresis &
+ W.LC_I_Grave &
+ W.LC_I_Acute &
+ W.LC_I_Circumflex &
+ W.LC_I_Diaeresis &
+ W.LC_N_Tilde &
+ W.LC_O_Grave &
+ W.LC_O_Acute &
+ W.LC_O_Circumflex &
+ W.LC_O_Tilde &
+ W.LC_O_Diaeresis &
+ W.LC_O_Oblique_Stroke &
+ W.LC_U_Grave &
+ W.LC_U_Acute &
+ W.LC_U_Circumflex &
+ W.LC_U_Diaeresis &
+ W.LC_Y_Acute &
+ W.LC_Y_Diaeresis,
+
+ Rangev =>
+ 'A' & -- UC_A_Grave
+ 'A' & -- UC_A_Acute
+ 'A' & -- UC_A_Circumflex
+ 'A' & -- UC_A_Tilde
+ 'A' & -- UC_A_Diaeresis
+ 'A' & -- UC_A_Ring
+ 'C' & -- UC_C_Cedilla
+ 'E' & -- UC_E_Grave
+ 'E' & -- UC_E_Acute
+ 'E' & -- UC_E_Circumflex
+ 'E' & -- UC_E_Diaeresis
+ 'I' & -- UC_I_Grave
+ 'I' & -- UC_I_Acute
+ 'I' & -- UC_I_Circumflex
+ 'I' & -- UC_I_Diaeresis
+ 'N' & -- UC_N_Tilde
+ 'O' & -- UC_O_Grave
+ 'O' & -- UC_O_Acute
+ 'O' & -- UC_O_Circumflex
+ 'O' & -- UC_O_Tilde
+ 'O' & -- UC_O_Diaeresis
+ 'O' & -- UC_O_Oblique_Stroke
+ 'U' & -- UC_U_Grave
+ 'U' & -- UC_U_Acute
+ 'U' & -- UC_U_Circumflex
+ 'U' & -- UC_U_Diaeresis
+ 'Y' & -- UC_Y_Acute
+ 'a' & -- LC_A_Grave
+ 'a' & -- LC_A_Acute
+ 'a' & -- LC_A_Circumflex
+ 'a' & -- LC_A_Tilde
+ 'a' & -- LC_A_Diaeresis
+ 'a' & -- LC_A_Ring
+ 'c' & -- LC_C_Cedilla
+ 'e' & -- LC_E_Grave
+ 'e' & -- LC_E_Acute
+ 'e' & -- LC_E_Circumflex
+ 'e' & -- LC_E_Diaeresis
+ 'i' & -- LC_I_Grave
+ 'i' & -- LC_I_Acute
+ 'i' & -- LC_I_Circumflex
+ 'i' & -- LC_I_Diaeresis
+ 'n' & -- LC_N_Tilde
+ 'o' & -- LC_O_Grave
+ 'o' & -- LC_O_Acute
+ 'o' & -- LC_O_Circumflex
+ 'o' & -- LC_O_Tilde
+ 'o' & -- LC_O_Diaeresis
+ 'o' & -- LC_O_Oblique_Stroke
+ 'u' & -- LC_U_Grave
+ 'u' & -- LC_U_Acute
+ 'u' & -- LC_U_Circumflex
+ 'u' & -- LC_U_Diaeresis
+ 'y' & -- LC_Y_Acute
+ 'y'); -- LC_Y_Diaeresis
+
+ Basic_Map : constant Wide_Character_Mapping :=
+ (AF.Controlled with
+ Basic_Mapping'Unrestricted_Access);
+
+end Ada.Strings.Wide_Maps.Wide_Constants;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1997-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.Wide_Text_IO; use Ada.Wide_Text_IO;
+
+package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_Wide_String is
+ Buffer : Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_String_Access;
+ Str2 : Wide_String_Access;
+
+ begin
+ Get_Line (Buffer, Last);
+ Str1 := new Wide_String'(Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ return To_Unbounded_Wide_String (Str1.all);
+ end Get_Line;
+
+ function Get_Line
+ (File : Ada.Wide_Text_IO.File_Type)
+ return Unbounded_Wide_String
+ is
+ Buffer : Wide_String (1 .. 1000);
+ Last : Natural;
+ Str1 : Wide_String_Access;
+ Str2 : Wide_String_Access;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Str1 := new Wide_String'(Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last));
+ Free (Str1);
+ Str1 := Str2;
+ end loop;
+
+ return To_Unbounded_Wide_String (Str1.all);
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_Wide_String) is
+ begin
+ Put (To_Wide_String (U));
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_Wide_String) is
+ begin
+ Put (File, To_Wide_String (U));
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_Wide_String) is
+ begin
+ Put_Line (To_Wide_String (U));
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is
+ begin
+ Put_Line (File, To_Wide_String (U));
+ end Put_Line;
+
+end Ada.Strings.Wide_Unbounded.Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1997-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 child package of Ada.Strings.Wide_Unbounded provides specialized
+-- Text_IO routines that work directly with unbounded strings, avoiding the
+-- inefficiencies of access via the standard interface, and also taking
+-- direct advantage of the variable length semantics of these strings.
+
+with Ada.Wide_Text_IO;
+
+package Ada.Strings.Wide_Unbounded.Wide_Text_IO is
+
+ function Get_Line
+ return Unbounded_Wide_String;
+ function Get_Line
+ (File : Ada.Wide_Text_IO.File_Type)
+ return Unbounded_Wide_String;
+ -- Reads up to the end of the current line, returning the result
+ -- as an unbounded string of appropriate length. If no File parameter
+ -- is present, input is from Current_Input.
+
+ procedure Put
+ (U : Unbounded_Wide_String);
+ procedure Put
+ (File : Ada.Wide_Text_IO.File_Type;
+ U : Unbounded_Wide_String);
+ procedure Put_Line
+ (U : Unbounded_Wide_String);
+ procedure Put_Line
+ (File : Ada.Wide_Text_IO.File_Type;
+ U : Unbounded_Wide_String);
+ -- These are equivalent to the standard Wide_Text_IO routines passed the
+ -- value To_Wide_String (U), but operate more efficiently, because the
+ -- extra copy of the argument is avoided.
+
+end Ada.Strings.Wide_Unbounded.Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D 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.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). --
+-- --
+------------------------------------------------------------------------------
+
+
+package body Ada.Synchronous_Task_Control is
+
+ -------------------
+ -- Suspension_PO --
+ -------------------
+
+ protected body Suspension_Object is
+
+ --------------
+ -- Get_Open --
+ --------------
+
+ function Get_Open return Boolean is
+ begin
+ return Open;
+ end Get_Open;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False is
+ begin
+ Open := False;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True is
+ begin
+ Open := True;
+ end Set_True;
+
+ ----------
+ -- Wait --
+ ----------
+
+ entry Wait when Open is
+ begin
+ Open := False;
+ end Wait;
+
+ --------------------
+ -- Wait_Exception --
+ --------------------
+
+ entry Wait_Exception when True is
+ begin
+ if Wait'Count /= 0 then
+ raise Program_Error;
+ end if;
+
+ requeue Wait;
+ end Wait_Exception;
+
+ end Suspension_Object;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ return S.Get_Open;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ begin
+ S.Set_False;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ begin
+ S.Set_True;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ begin
+ S.Wait_Exception;
+ end Suspend_Until_True;
+
+end Ada.Synchronous_Task_Control;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D 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.11 $ --
+-- --
+-- 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;
+
+package Ada.Synchronous_Task_Control is
+
+ type Suspension_Object is limited private;
+
+ procedure Set_True (S : in out Suspension_Object);
+
+ procedure Set_False (S : in out Suspension_Object);
+
+ function Current_State (S : Suspension_Object) return Boolean;
+
+ procedure Suspend_Until_True (S : in out Suspension_Object);
+
+private
+
+ -- ??? Using a protected object is overkill; suspension could be
+ -- implemented more efficiently.
+
+ protected type Suspension_Object is
+ entry Wait;
+ procedure Set_False;
+ procedure Set_True;
+ function Get_Open return Boolean;
+ entry Wait_Exception;
+
+ pragma Priority (System.Any_Priority'Last);
+ private
+ Open : Boolean := False;
+ end Suspension_Object;
+
+end Ada.Synchronous_Task_Control;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T A G S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.30 $
+-- --
+-- 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.Exceptions;
+with Unchecked_Conversion;
+with GNAT.HTable;
+
+pragma Elaborate_All (GNAT.HTable);
+
+package body Ada.Tags is
+
+-- Structure of the GNAT Dispatch Table
+
+-- +----------------------+
+-- | TSD pointer ---|-----> Type Specific Data
+-- +----------------------+ +-------------------+
+-- | table of | | inheritance depth |
+-- : primitive ops : +-------------------+
+-- | pointers | | expanded name |
+-- +----------------------+ +-------------------+
+-- | external tag |
+-- +-------------------+
+-- | Hash table link |
+-- +-------------------+
+-- | Remotely Callable |
+-- +-------------------+
+-- | Rec Ctrler offset |
+-- +-------------------+
+-- | table of |
+-- : ancestor :
+-- | tags |
+-- +-------------------+
+
+ use System;
+
+ subtype Cstring is String (Positive);
+ type Cstring_Ptr is access all Cstring;
+ type Tag_Table is array (Natural range <>) of Tag;
+ pragma Suppress_Initialization (Tag_Table);
+
+ type Wide_Boolean is (False, True);
+ for Wide_Boolean'Size use Standard'Address_Size;
+
+ type Type_Specific_Data is record
+ Idepth : Natural;
+ Expanded_Name : Cstring_Ptr;
+ External_Tag : Cstring_Ptr;
+ HT_Link : Tag;
+ Remotely_Callable : Wide_Boolean;
+ RC_Offset : SSE.Storage_Offset;
+ Ancestor_Tags : Tag_Table (Natural);
+ end record;
+
+ type Dispatch_Table is record
+ TSD : Type_Specific_Data_Ptr;
+ Prims_Ptr : Address_Array (Positive);
+ end record;
+
+ -------------------------------------------
+ -- Unchecked Conversions for Tag and TSD --
+ -------------------------------------------
+
+ function To_Type_Specific_Data_Ptr is
+ new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
+
+ function To_Address is new Unchecked_Conversion (Tag, Address);
+ function To_Address is
+ new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
+
+ ---------------------------------------------
+ -- Unchecked Conversions for String Fields --
+ ---------------------------------------------
+
+ function To_Cstring_Ptr is
+ new Unchecked_Conversion (Address, Cstring_Ptr);
+
+ function To_Address is
+ new Unchecked_Conversion (Cstring_Ptr, Address);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Length (Str : Cstring_Ptr) return Natural;
+ -- Length of string represented by the given pointer (treating the
+ -- string as a C-style string, which is Nul terminated).
+
+ -------------------------
+ -- External_Tag_HTable --
+ -------------------------
+
+ type HTable_Headers is range 1 .. 64;
+
+ -- The following internal package defines the routines used for
+ -- the instantiation of a new GNAT.HTable.Static_HTable (see
+ -- below). See spec in g-htable.ads for details of usage.
+
+ package HTable_Subprograms is
+ procedure Set_HT_Link (T : Tag; Next : Tag);
+ function Get_HT_Link (T : Tag) return Tag;
+ function Hash (F : Address) return HTable_Headers;
+ function Equal (A, B : Address) return Boolean;
+ end HTable_Subprograms;
+
+ package External_Tag_HTable is new GNAT.HTable.Static_HTable (
+ Header_Num => HTable_Headers,
+ Element => Dispatch_Table,
+ Elmt_Ptr => Tag,
+ Null_Ptr => null,
+ Set_Next => HTable_Subprograms.Set_HT_Link,
+ Next => HTable_Subprograms.Get_HT_Link,
+ Key => Address,
+ Get_Key => Get_External_Tag,
+ Hash => HTable_Subprograms.Hash,
+ Equal => HTable_Subprograms.Equal);
+
+ ------------------------
+ -- HTable_Subprograms --
+ ------------------------
+
+ -- Bodies of routines for hash table instantiation
+
+ package body HTable_Subprograms is
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (A, B : Address) return Boolean is
+ Str1 : Cstring_Ptr := To_Cstring_Ptr (A);
+ Str2 : Cstring_Ptr := To_Cstring_Ptr (B);
+ J : Integer := 1;
+
+ begin
+ loop
+ if Str1 (J) /= Str2 (J) then
+ return False;
+
+ elsif Str1 (J) = ASCII.NUL then
+ return True;
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+ end Equal;
+
+ -----------------
+ -- Get_HT_Link --
+ -----------------
+
+ function Get_HT_Link (T : Tag) return Tag is
+ begin
+ return T.TSD.HT_Link;
+ end Get_HT_Link;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Address) return HTable_Headers is
+ function H is new GNAT.HTable.Hash (HTable_Headers);
+ Str : Cstring_Ptr := To_Cstring_Ptr (F);
+ Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
+
+ begin
+ return Res;
+ end Hash;
+
+ -----------------
+ -- Set_HT_Link --
+ -----------------
+
+ procedure Set_HT_Link (T : Tag; Next : Tag) is
+ begin
+ T.TSD.HT_Link := Next;
+ end Set_HT_Link;
+
+ end HTable_Subprograms;
+
+ --------------------
+ -- CW_Membership --
+ --------------------
+
+ -- Canonical implementation of Classwide Membership corresponding to:
+
+ -- Obj in Typ'Class
+
+ -- Each dispatch table contains a reference to a table of ancestors
+ -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
+
+ -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
+ -- contained in the dispatch table referenced by Obj'Tag . Knowing the
+ -- level of inheritance of both types, this can be computed in constant
+ -- time by the formula:
+
+ -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
+ -- = Typ'tag
+
+ function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
+ Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
+
+ begin
+ return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
+ end CW_Membership;
+
+ -------------------
+ -- Expanded_Name --
+ -------------------
+
+ function Expanded_Name (T : Tag) return String is
+ Result : Cstring_Ptr := T.TSD.Expanded_Name;
+
+ begin
+ return Result (1 .. Length (Result));
+ end Expanded_Name;
+
+ ------------------
+ -- External_Tag --
+ ------------------
+
+ function External_Tag (T : Tag) return String is
+ Result : Cstring_Ptr := T.TSD.External_Tag;
+
+ begin
+ return Result (1 .. Length (Result));
+ end External_Tag;
+
+ -----------------------
+ -- Get_Expanded_Name --
+ -----------------------
+
+ function Get_Expanded_Name (T : Tag) return Address is
+ begin
+ return To_Address (T.TSD.Expanded_Name);
+ end Get_Expanded_Name;
+
+ ----------------------
+ -- Get_External_Tag --
+ ----------------------
+
+ function Get_External_Tag (T : Tag) return Address is
+ begin
+ return To_Address (T.TSD.External_Tag);
+ end Get_External_Tag;
+
+ ---------------------------
+ -- Get_Inheritance_Depth --
+ ---------------------------
+
+ function Get_Inheritance_Depth (T : Tag) return Natural is
+ begin
+ return T.TSD.Idepth;
+ end Get_Inheritance_Depth;
+
+ -------------------------
+ -- Get_Prim_Op_Address --
+ -------------------------
+
+ function Get_Prim_Op_Address
+ (T : Tag;
+ Position : Positive)
+ return Address
+ is
+ begin
+ return T.Prims_Ptr (Position);
+ end Get_Prim_Op_Address;
+
+ -------------------
+ -- Get_RC_Offset --
+ -------------------
+
+ function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
+ begin
+ return T.TSD.RC_Offset;
+ end Get_RC_Offset;
+
+ ---------------------------
+ -- Get_Remotely_Callable --
+ ---------------------------
+
+ function Get_Remotely_Callable (T : Tag) return Boolean is
+ begin
+ return T.TSD.Remotely_Callable = True;
+ end Get_Remotely_Callable;
+
+ -------------
+ -- Get_TSD --
+ -------------
+
+ function Get_TSD (T : Tag) return Address is
+ begin
+ return To_Address (T.TSD);
+ end Get_TSD;
+
+ ----------------
+ -- Inherit_DT --
+ ----------------
+
+ procedure Inherit_DT
+ (Old_T : Tag;
+ New_T : Tag;
+ Entry_Count : Natural)
+ is
+ begin
+ if Old_T /= null then
+ New_T.Prims_Ptr (1 .. Entry_Count) :=
+ Old_T.Prims_Ptr (1 .. Entry_Count);
+ end if;
+ end Inherit_DT;
+
+ -----------------
+ -- Inherit_TSD --
+ -----------------
+
+ procedure Inherit_TSD (Old_TSD : Address; New_Tag : Tag) is
+ TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (Old_TSD);
+ New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
+
+ begin
+ if TSD /= null then
+ New_TSD.Idepth := TSD.Idepth + 1;
+ New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
+ := TSD.Ancestor_Tags (0 .. TSD.Idepth);
+ else
+ New_TSD.Idepth := 0;
+ end if;
+
+ New_TSD.Ancestor_Tags (0) := New_Tag;
+ end Inherit_TSD;
+
+ ------------------
+ -- Internal_Tag --
+ ------------------
+
+ function Internal_Tag (External : String) return Tag is
+ Ext_Copy : aliased String (External'First .. External'Last + 1);
+ Res : Tag;
+
+ begin
+ -- Make a copy of the string representing the external tag with
+ -- a null at the end
+
+ Ext_Copy (External'Range) := External;
+ Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
+ Res := External_Tag_HTable.Get (Ext_Copy'Address);
+
+ if Res = null then
+ declare
+ Msg1 : constant String := "unknown tagged type: ";
+ Msg2 : String (1 .. Msg1'Length + External'Length);
+
+ begin
+ Msg2 (1 .. Msg1'Length) := Msg1;
+ Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
+ External;
+ Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
+ end;
+ end if;
+
+ return Res;
+ end Internal_Tag;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Str : Cstring_Ptr) return Natural is
+ Len : Integer := 1;
+
+ begin
+ while Str (Len) /= ASCII.Nul loop
+ Len := Len + 1;
+ end loop;
+
+ return Len - 1;
+ end Length;
+
+ -----------------
+ -- Parent_Size --
+ -----------------
+
+ -- Fake type with a tag as first component. Should match the
+ -- layout of all tagged types.
+
+ type T is record
+ A : Tag;
+ end record;
+
+ type T_Ptr is access all T;
+
+ function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr);
+
+ -- The profile of the implicitly defined _size primitive
+
+ type Acc_Size is access function (A : Address) return Long_Long_Integer;
+ function To_Acc_Size is new Unchecked_Conversion (Address, Acc_Size);
+
+ function Parent_Size (Obj : Address) return SSE.Storage_Count is
+
+ -- Get the tag of the object
+
+ Obj_Tag : constant Tag := To_T_Ptr (Obj).A;
+
+ -- Get the tag of the parent type through the dispatch table
+
+ Parent_Tag : constant Tag := Obj_Tag.TSD.Ancestor_Tags (1);
+
+ -- Get an access to the _size primitive of the parent. We assume that
+ -- it is always in the first slot of the distatch table
+
+ F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
+
+ begin
+ -- Here we compute the size of the _parent field of the object
+
+ return SSE.Storage_Count (F.all (Obj));
+ end Parent_Size;
+
+ ------------------
+ -- Register_Tag --
+ ------------------
+
+ procedure Register_Tag (T : Tag) is
+ begin
+ External_Tag_HTable.Set (T);
+ end Register_Tag;
+
+ -----------------------
+ -- Set_Expanded_Name --
+ -----------------------
+
+ procedure Set_Expanded_Name (T : Tag; Value : Address) is
+ begin
+ T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
+ end Set_Expanded_Name;
+
+ ----------------------
+ -- Set_External_Tag --
+ ----------------------
+
+ procedure Set_External_Tag (T : Tag; Value : Address) is
+ begin
+ T.TSD.External_Tag := To_Cstring_Ptr (Value);
+ end Set_External_Tag;
+
+ ---------------------------
+ -- Set_Inheritance_Depth --
+ ---------------------------
+
+ procedure Set_Inheritance_Depth
+ (T : Tag;
+ Value : Natural)
+ is
+ begin
+ T.TSD.Idepth := Value;
+ end Set_Inheritance_Depth;
+
+ -------------------------
+ -- Set_Prim_Op_Address --
+ -------------------------
+
+ procedure Set_Prim_Op_Address
+ (T : Tag;
+ Position : Positive;
+ Value : Address)
+ is
+ begin
+ T.Prims_Ptr (Position) := Value;
+ end Set_Prim_Op_Address;
+
+ -------------------
+ -- Set_RC_Offset --
+ -------------------
+
+ procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
+ begin
+ T.TSD.RC_Offset := Value;
+ end Set_RC_Offset;
+
+ ---------------------------
+ -- Set_Remotely_Callable --
+ ---------------------------
+
+ procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
+ begin
+ if Value then
+ T.TSD.Remotely_Callable := True;
+ else
+ T.TSD.Remotely_Callable := False;
+ end if;
+ end Set_Remotely_Callable;
+
+ -------------
+ -- Set_TSD --
+ -------------
+
+ procedure Set_TSD (T : Tag; Value : Address) is
+ begin
+ T.TSD := To_Type_Specific_Data_Ptr (Value);
+ end Set_TSD;
+
+end Ada.Tags;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T A G S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.23 $ --
+-- --
+-- 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;
+with System.Storage_Elements;
+
+package Ada.Tags is
+
+ pragma Elaborate_Body;
+
+ type Tag is private;
+
+ function Expanded_Name (T : Tag) return String;
+
+ function External_Tag (T : Tag) return String;
+
+ function Internal_Tag (External : String) return Tag;
+
+ Tag_Error : exception;
+
+private
+
+ ----------------------------------------------------------------
+ -- Abstract procedural interface for the GNAT dispatch table --
+ ----------------------------------------------------------------
+
+ -- GNAT's Dispatch Table format is customizable in order to match the
+ -- format used in another langauge. GNAT supports programs that use
+ -- two different dispatch table format at the same time: the native
+ -- format that supports Ada 95 tagged types and which is described in
+ -- Ada.Tags and a foreign format for types that are imported from some
+ -- other language (typically C++) which is described in interfaces.cpp.
+ -- The runtime information kept for each tagged type is separated into
+ -- two objects: the Dispatch Table and the Type Specific Data record.
+ -- These two objects are allocated statically using the constants:
+
+ -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
+ -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
+
+ -- where Nb_prim is the number of primitive operations of the given
+ -- type and Idepth its inheritance depth.
+
+ -- The compiler generates calls to the following SET routines to
+ -- initialize those structures and uses the GET functions to
+ -- retreive the information when needed
+
+ package S renames System;
+ package SSE renames System.Storage_Elements;
+
+ function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
+ -- Given the tag of an object and the tag associated to a type, return
+ -- true if Obj is in Typ'Class.
+
+ function Get_Expanded_Name (T : Tag) return S.Address;
+ -- Retrieve the address of a null terminated string containing
+ -- the expanded name
+
+ function Get_External_Tag (T : Tag) return S.Address;
+ -- Retrieve the address of a null terminated string containing
+ -- the external name
+
+ function Get_Prim_Op_Address
+ (T : Tag;
+ Position : Positive)
+ return S.Address;
+ -- Given a pointer to a dispatch Table (T) and a position in the DT
+ -- this function returns the address of the virtual function stored
+ -- in it (used for dispatching calls)
+
+ function Get_Inheritance_Depth (T : Tag) return Natural;
+ -- Given a pointer to a dispatch Table, retrieves the value representing
+ -- the depth in the inheritance tree (used for membership).
+
+ function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
+ -- Return the Offset of the implicit record controller when the object
+ -- has controlled components. O otherwise.
+
+ pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
+ -- This procedure is used in s-finimp to compute the deep routines
+ -- it is exported manually in order to avoid changing completely the
+ -- organization of the run time.
+
+ function Get_Remotely_Callable (T : Tag) return Boolean;
+ -- Return the value previously set by Set_Remotely_Callable
+
+ function Get_TSD (T : Tag) return S.Address;
+ -- Given a pointer T to a dispatch Table, retreives the address of the
+ -- record containing the Type Specific Data generated by GNAT
+
+ procedure Inherit_DT
+ (Old_T : Tag;
+ New_T : Tag;
+ Entry_Count : Natural);
+ -- Entry point used to initialize the DT of a type knowing the tag
+ -- of the direct ancestor and the number of primitive ops that are
+ -- inherited (Entry_Count).
+
+ procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag);
+ -- Entry point used to initialize the TSD of a type knowing the
+ -- TSD of the direct ancestor.
+
+ function Parent_Size (Obj : S.Address) return SSE.Storage_Count;
+ -- Computes the size of field _Parent of a tagged extension object
+ -- whose address is 'obj' by calling the indirectly _size function of
+ -- the parent. This function assumes that _size is always in slot 1 of
+ -- the dispatch table.
+
+ pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
+ -- This procedure is used in s-finimp and is thus exported manually
+
+ procedure Register_Tag (T : Tag);
+ -- Insert the Tag and its associated external_tag in a table for the
+ -- sake of Internal_Tag
+
+ procedure Set_Inheritance_Depth
+ (T : Tag;
+ Value : Natural);
+ -- Given a pointer to a dispatch Table, stores the value representing
+ -- the depth in the inheritance tree (the second parameter). Used during
+ -- elaboration of the tagged type.
+
+ procedure Set_Prim_Op_Address
+ (T : Tag;
+ Position : Positive;
+ Value : S.Address);
+ -- Given a pointer to a dispatch Table (T) and a position in the
+ -- dispatch Table put the address of the virtual function in it
+ -- (used for overriding)
+
+ procedure Set_TSD (T : Tag; Value : S.Address);
+ -- Given a pointer T to a dispatch Table, stores the address of the record
+ -- containing the Type Specific Data generated by GNAT
+
+ procedure Set_Expanded_Name (T : Tag; Value : S.Address);
+ -- Set the address of the string containing the expanded name
+ -- in the Dispatch table
+
+ procedure Set_External_Tag (T : Tag; Value : S.Address);
+ -- Set the address of the string containing the external tag
+ -- in the Dispatch table
+
+ procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
+ -- Sets the Offset of the implicit record controller when the object
+ -- has controlled components. Set to O otherwise.
+
+ procedure Set_Remotely_Callable (T : Tag; Value : Boolean);
+ -- Set to true if the type has been declared in a context described
+ -- in E.4 (18)
+
+ DT_Prologue_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count
+ (Standard'Address_Size / S.Storage_Unit);
+ -- Size of the first part of the dispatch table
+
+ DT_Entry_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count
+ (Standard'Address_Size / S.Storage_Unit);
+ -- Size of each primitive operation entry in the Dispatch Table.
+
+ TSD_Prologue_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count
+ (6 * Standard'Address_Size / S.Storage_Unit);
+ -- Size of the first part of the type specific data
+
+ TSD_Entry_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count (Standard'Address_Size / S.Storage_Unit);
+ -- Size of each ancestor tag entry in the TSD
+
+ type Address_Array is array (Natural range <>) of S.Address;
+
+ type Dispatch_Table;
+ type Tag is access all Dispatch_Table;
+
+ type Type_Specific_Data;
+ type Type_Specific_Data_Ptr is access all Type_Specific_Data;
+
+ pragma Inline_Always (CW_Membership);
+ pragma Inline_Always (Get_Expanded_Name);
+ pragma Inline_Always (Get_Inheritance_Depth);
+ pragma Inline_Always (Get_Prim_Op_Address);
+ pragma Inline_Always (Get_RC_Offset);
+ pragma Inline_Always (Get_Remotely_Callable);
+ pragma Inline_Always (Get_TSD);
+ pragma Inline_Always (Inherit_DT);
+ pragma Inline_Always (Inherit_TSD);
+ pragma Inline_Always (Register_Tag);
+ pragma Inline_Always (Set_Expanded_Name);
+ pragma Inline_Always (Set_External_Tag);
+ pragma Inline_Always (Set_Inheritance_Depth);
+ pragma Inline_Always (Set_Prim_Op_Address);
+ pragma Inline_Always (Set_RC_Offset);
+ pragma Inline_Always (Set_Remotely_Callable);
+ pragma Inline_Always (Set_TSD);
+end Ada.Tags;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T A S K _ A T T R I B U T E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1991-2000 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- The following notes are provided in case someone decides the
+-- implementation of this package is too complicated, or too slow.
+-- Please read this before making any "simplifications".
+
+-- Correct implementation of this package is more difficult than one
+-- might expect. After considering (and coding) several alternatives,
+-- we settled on the present compromise. Things we do not like about
+-- this implementation include:
+
+-- - It is vulnerable to bad Task_ID values, to the extent of
+-- possibly trashing memory and crashing the runtime system.
+
+-- - It requires dynamic storage allocation for each new attribute value,
+-- except for types that happen to be the same size as System.Address,
+-- or shorter.
+
+-- - Instantiations at other than the library level rely on being able to
+-- do down-level calls to a procedure declared in the generic package body.
+-- This makes it potentially vulnerable to compiler changes.
+
+-- The main implementation issue here is that the connection from
+-- task to attribute is a potential source of dangling references.
+
+-- When a task goes away, we want to be able to recover all the storage
+-- associated with its attributes. The Ada mechanism for this is
+-- finalization, via controlled attribute types. For this reason,
+-- the ARM requires finalization of attribute values when the
+-- associated task terminates.
+
+-- This finalization must be triggered by the tasking runtime system,
+-- during termination of the task. Given the active set of instantiations
+-- of Ada.Task_Attributes is dynamic, the number and types of attributes
+-- belonging to a task will not be known until the task actually terminates.
+-- Some of these types may be controlled and some may not. The RTS must find
+-- some way to determine which of these attributes need finalization, and
+-- invoke the appropriate finalization on them.
+
+-- One way this might be done is to create a special finalization chain
+-- for each task, similar to the finalization chain that is used for
+-- controlled objects within the task. This would differ from the usual
+-- finalization chain in that it would not have a LIFO structure, since
+-- attributes may be added to a task at any time during its lifetime.
+-- This might be the right way to go for the longer term, but at present
+-- this approach is not open, since GNAT does not provide such special
+-- finalization support.
+
+-- Lacking special compiler support, the RTS is limited to the
+-- normal ways an application invokes finalization, i.e.
+
+-- a) Explicit call to the procedure Finalize, if we know the type
+-- has this operation defined on it. This is not sufficient, since
+-- we have no way of determining whether a given generic formal
+-- Attribute type is controlled, and no visibility of the associated
+-- Finalize procedure, in the generic body.
+
+-- b) Leaving the scope of a local object of a controlled type.
+-- This does not help, since the lifetime of an instantiation of
+-- Ada.Task_Attributes does not correspond to the lifetimes of the
+-- various tasks which may have that attribute.
+
+-- c) Assignment of another value to the object. This would not help,
+-- since we then have to finalize the new value of the object.
+
+-- d) Unchecked deallocation of an object of a controlled type.
+-- This seems to be the only mechanism available to the runtime
+-- system for finalization of task attributes.
+
+-- We considered two ways of using unchecked deallocation, both based
+-- on a linked list of that would hang from the task control block.
+
+-- In the first approach the objects on the attribute list are all derived
+-- from one controlled type, say T, and are linked using an access type to
+-- T'Class. The runtime system has an Unchecked_Deallocation for T'Class
+-- with access type T'Class, and uses this to deallocate and finalize all
+-- the items in the list. The limitation of this approach is that each
+-- instantiation of the package Ada.Task_Attributes derives a new record
+-- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation
+-- is only allowed at the library level.
+
+-- In the second approach the objects on the attribute list are of
+-- unrelated but structurally similar types. Unchecked conversion is
+-- used to circument Ada type checking. Each attribute-storage node
+-- contains not only the attribute value and a link for chaining, but
+-- also a pointer to a descriptor for the corresponding instantiation
+-- of Task_Attributes. The instantiation-descriptor contains a
+-- pointer to a procedure that can do the correct deallocation and
+-- finalization for that type of attribute. On task termination, the
+-- runtime system uses the pointer to call the appropriate deallocator.
+
+-- While this gets around the limitation that instantations be at
+-- the library level, it relies on an implementation feature that
+-- may not always be safe, i.e. that it is safe to call the
+-- Deallocate procedure for an instantiation of Ada.Task_Attributes
+-- that no longer exists. In general, it seems this might result in
+-- dangling references.
+
+-- Another problem with instantiations deeper than the library level
+-- is that there is risk of storage leakage, or dangling references
+-- to reused storage. That is, if an instantiation of Ada.Task_Attributes
+-- is made within a procedure, what happens to the storage allocated for
+-- attributes, when the procedure call returns? Apparently (RM 7.6.1 (4))
+-- any such objects must be finalized, since they will no longer be
+-- accessible, and in general one would expect that the storage they occupy
+-- would be recovered for later reuse. (If not, we would have a case of
+-- storage leakage.) Assuming the storage is recovered and later reused,
+-- we have potentially dangerous dangling references. When the procedure
+-- containing the instantiation of Ada.Task_Attributes returns, there
+-- may still be unterminated tasks with associated attribute values for
+-- that instantiation. When such tasks eventually terminate, the RTS
+-- will attempt to call the Deallocate procedure on them. If the
+-- corresponding storage has already been deallocated, when the master
+-- of the access type was left, we have a potential disaster. This
+-- disaster is compounded since the pointer to Deallocate is probably
+-- through a "trampoline" which will also have been destroyed.
+
+-- For this reason, we arrange to remove all dangling references
+-- before leaving the scope of an instantiation. This is ugly, since
+-- it requires traversing the list of all tasks, but it is no more ugly
+-- than a similar traversal that we must do at the point of instantiation
+-- in order to initialize the attributes of all tasks. At least we only
+-- need to do these traversals if the type is controlled.
+
+-- We chose to defer allocation of storage for attributes until the
+-- Reference function is called or the attribute is first set to a value
+-- different from the default initial one. This allows a potential
+-- savings in allocation, for attributes that are not used by all tasks.
+
+-- For efficiency, we reserve space in the TCB for a fixed number of
+-- direct-access attributes. These are required to be of a size that
+-- fits in the space of an object of type System.Address. Because
+-- we must use unchecked bitwise copy operations on these values, they
+-- cannot be of a controlled type, but that is covered automatically
+-- since controlled objects are too large to fit in the spaces.
+
+-- We originally deferred the initialization of these direct-access
+-- attributes, just as we do for the indirect-access attributes, and
+-- used a per-task bit vector to keep track of which attributes were
+-- currently defined for that task. We found that the overhead of
+-- maintaining this bit-vector seriously slowed down access to the
+-- attributes, and made the fetch operation non-atomic, so that even
+-- to read an attribute value required locking the TCB. Therefore,
+-- we now initialize such attributes for all existing tasks at the time
+-- of the attribute instantiation, and initialize existing attributes
+-- for each new task at the time it is created.
+
+-- The latter initialization requires a list of all the instantiation
+-- descriptors. Updates to this list, as well as the bit-vector that
+-- is used to reserve slots for attributes in the TCB, require mutual
+-- exclusion. That is provided by the lock
+-- System.Tasking.Task_Attributes.All_Attrs_L.
+
+-- One special problem that added complexity to the design is that
+-- the per-task list of indirect attributes contains objects of
+-- different types. We use unchecked pointer conversion to link
+-- these nodes together and access them, but the records may not have
+-- identical internal structure. Initially, we thought it would be
+-- enough to allocate all the common components of the records at the
+-- front of each record, so that their positions would correspond.
+-- Unfortunately, GNAT adds "dope" information at the front of a record,
+-- if the record contains any controlled-type components.
+--
+-- This means that the offset of the fields we use to link the nodes is
+-- at different positions on nodes of different types. To get around this,
+-- each attribute storage record consists of a core node and wrapper.
+-- The core nodes are all of the same type, and it is these that are
+-- linked together and generally "seen" by the RTS. Each core node
+-- contains a pointer to its own wrapper, which is a record that contains
+-- the core node along with an attribute value, approximately
+-- as follows:
+
+-- type Node;
+-- type Node_Access is access all Node;
+-- type Node_Access;
+-- type Access_Wrapper is access all Wrapper;
+-- type Node is record
+-- Next : Node_Access;
+-- ...
+-- Wrapper : Access_Wrapper;
+-- end record;
+-- type Wrapper is record
+-- Noed : aliased Node;
+-- Value : aliased Attribute; -- the generic formal type
+-- end record;
+
+-- Another interesting problem is with the initialization of
+-- the instantiation descriptors. Originally, we did this all via
+-- the Initialize procedure of the descriptor type and code in the
+-- package body. It turned out that the Initialize procedure needed
+-- quite a bit of information, including the size of the attribute
+-- type, the initial value of the attribute (if it fits in the TCB),
+-- and a pointer to the deallocator procedure. These needed to be
+-- "passed" in via access discriminants. GNAT was having trouble
+-- with access discriminants, so all this work was moved to the
+-- package body.
+
+with Ada.Task_Identification;
+-- used for Task_Id
+-- Null_Task_ID
+-- Current_Task
+
+with System.Error_Reporting;
+-- used for Shutdown;
+
+with System.Storage_Elements;
+-- used for Integer_Address
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Unlock
+-- Lock/Unlock_All_Tasks_List
+
+with System.Tasking;
+-- used for Access_Address
+-- Task_ID
+-- Direct_Index_Vector
+-- Direct_Index
+
+with System.Tasking.Initialization;
+-- used for Defer_Abortion
+-- Undefer_Abortion
+-- Initialize_Attributes_Link
+-- Finalize_Attributes_Link
+
+with System.Tasking.Task_Attributes;
+-- used for Access_Node
+-- Access_Dummy_Wrapper
+-- Deallocator
+-- Instance
+-- Node
+-- Access_Instance
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+pragma Elaborate_All (System.Tasking.Task_Attributes);
+-- to ensure the initialization of object Local (below) will work
+
+package body Ada.Task_Attributes is
+
+ use System.Error_Reporting,
+ System.Tasking.Initialization,
+ System.Tasking,
+ System.Tasking.Task_Attributes,
+ Ada.Exceptions;
+
+ use type System.Tasking.Access_Address;
+
+ package POP renames System.Task_Primitives.Operations;
+
+ ---------------------------
+ -- Unchecked Conversions --
+ ---------------------------
+
+ pragma Warnings (Off);
+ -- These unchecked conversions can give warnings when alignments
+ -- are incorrect, but they will not be used in such cases anyway,
+ -- so the warnings can be safely ignored.
+
+ -- The following type corresponds to Dummy_Wrapper,
+ -- declared in System.Tasking.Task_Attributes.
+
+ type Wrapper;
+ type Access_Wrapper is access all Wrapper;
+
+ function To_Attribute_Handle is new Unchecked_Conversion
+ (Access_Address, Attribute_Handle);
+ -- For reference to directly addressed task attributes
+
+ type Access_Integer_Address is access all
+ System.Storage_Elements.Integer_Address;
+
+ function To_Attribute_Handle is new Unchecked_Conversion
+ (Access_Integer_Address, Attribute_Handle);
+ -- For reference to directly addressed task attributes
+
+ function To_Access_Address is new Unchecked_Conversion
+ (Access_Node, Access_Address);
+ -- To store pointer to list of indirect attributes
+
+ function To_Access_Node is new Unchecked_Conversion
+ (Access_Address, Access_Node);
+ -- To fetch pointer to list of indirect attributes
+
+ function To_Access_Wrapper is new Unchecked_Conversion
+ (Access_Dummy_Wrapper, Access_Wrapper);
+ -- To fetch pointer to actual wrapper of attribute node
+
+ function To_Access_Dummy_Wrapper is new Unchecked_Conversion
+ (Access_Wrapper, Access_Dummy_Wrapper);
+ -- To store pointer to actual wrapper of attribute node
+
+ function To_Task_ID is new Unchecked_Conversion
+ (Task_Identification.Task_Id, Task_ID);
+ -- To access TCB of identified task
+
+ Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id);
+ -- ??? need comments on use and purpose
+
+ type Local_Deallocator is
+ access procedure (P : in out Access_Node);
+
+ function To_Lib_Level_Deallocator is new Unchecked_Conversion
+ (Local_Deallocator, Deallocator);
+ -- To defeat accessibility check
+
+ pragma Warnings (On);
+
+ ------------------------
+ -- Storage Management --
+ ------------------------
+
+ procedure Deallocate (P : in out Access_Node);
+ -- Passed to the RTS via unchecked conversion of a pointer to
+ -- permit finalization and deallocation of attribute storage nodes
+
+ --------------------------
+ -- Instantiation Record --
+ --------------------------
+
+ Local : aliased Instance;
+ -- Initialized in package body
+
+ type Wrapper is record
+ Noed : aliased Node;
+
+ Value : aliased Attribute := Initial_Value;
+ -- The generic formal type, may be controlled
+ end record;
+
+ procedure Free is
+ new Unchecked_Deallocation (Wrapper, Access_Wrapper);
+
+ procedure Deallocate (P : in out Access_Node) is
+ T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
+
+ begin
+ Free (T);
+
+ exception
+ when others =>
+ pragma Assert (Shutdown ("Exception in Deallocate")); null;
+ end Deallocate;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ return Attribute_Handle
+ is
+ TT : Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to get the reference of a";
+
+ begin
+ if TT = Null_ID then
+ Raise_Exception (Program_Error'Identity,
+ Error_Message & "null task");
+ end if;
+
+ if TT.Common.State = Terminated then
+ Raise_Exception (Tasking_Error'Identity,
+ Error_Message & "terminated task");
+ end if;
+
+ begin
+ Defer_Abortion;
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ if Local.Index /= 0 then
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return
+ To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access);
+
+ else
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
+
+ begin
+ while P /= null loop
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return To_Access_Wrapper (P.Wrapper).Value'Access;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ -- Unlock All_Attrs_L here to follow the lock ordering rule
+ -- that prevent us from using new (i.e the Global_Lock) while
+ -- holding any other lock.
+
+ POP.Unlock (All_Attrs_L'Access);
+ W := new Wrapper'
+ ((null, Local'Unchecked_Access, null), Initial_Value);
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ P := W.Noed'Unchecked_Access;
+ P.Wrapper := To_Access_Dummy_Wrapper (W);
+ P.Next := To_Access_Node (TT.Indirect_Attributes);
+ TT.Indirect_Attributes := To_Access_Address (P);
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return W.Value'Access;
+ end;
+ end if;
+
+ pragma Assert (Shutdown ("Should never get here in Reference"));
+ return null;
+
+ exception
+ when others =>
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ raise;
+ end;
+
+ exception
+ when Tasking_Error | Program_Error =>
+ raise;
+
+ when others =>
+ raise Program_Error;
+ end Reference;
+
+ ------------------
+ -- Reinitialize --
+ ------------------
+
+ procedure Reinitialize
+ (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ is
+ TT : Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to Reinitialize a";
+
+ begin
+ if TT = Null_ID then
+ Raise_Exception (Program_Error'Identity,
+ Error_Message & "null task");
+ end if;
+
+ if TT.Common.State = Terminated then
+ Raise_Exception (Tasking_Error'Identity,
+ Error_Message & "terminated task");
+ end if;
+
+ if Local.Index = 0 then
+ declare
+ P, Q : Access_Node;
+ W : Access_Wrapper;
+
+ begin
+ Defer_Abortion;
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ Q := To_Access_Node (TT.Indirect_Attributes);
+ while Q /= null loop
+ if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
+ if P = null then
+ TT.Indirect_Attributes := To_Access_Address (Q.Next);
+ else
+ P.Next := Q.Next;
+ end if;
+
+ W := To_Access_Wrapper (Q.Wrapper);
+ Free (W);
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return;
+ end if;
+
+ P := Q;
+ Q := Q.Next;
+ end loop;
+
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+
+ exception
+ when others =>
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ end;
+
+ else
+ Set_Value (Initial_Value, T);
+ end if;
+
+ exception
+ when Tasking_Error | Program_Error =>
+ raise;
+
+ when others =>
+ raise Program_Error;
+ end Reinitialize;
+
+ ---------------
+ -- Set_Value --
+ ---------------
+
+ procedure Set_Value
+ (Val : Attribute;
+ T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ is
+ TT : Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to Set the Value of a";
+
+ begin
+ if TT = Null_ID then
+ Raise_Exception (Program_Error'Identity,
+ Error_Message & "null task");
+ end if;
+
+ if TT.Common.State = Terminated then
+ Raise_Exception (Tasking_Error'Identity,
+ Error_Message & "terminated task");
+ end if;
+
+ begin
+ Defer_Abortion;
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ if Local.Index /= 0 then
+ To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Access).all := Val;
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return;
+
+ else
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
+
+ begin
+ while P /= null loop
+
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ To_Access_Wrapper (P.Wrapper).Value := Val;
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ -- Unlock TT here to follow the lock ordering rule that
+ -- prevent us from using new (i.e the Global_Lock) while
+ -- holding any other lock.
+
+ POP.Unlock (All_Attrs_L'Access);
+ W := new Wrapper'
+ ((null, Local'Unchecked_Access, null), Val);
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ P := W.Noed'Unchecked_Access;
+ P.Wrapper := To_Access_Dummy_Wrapper (W);
+ P.Next := To_Access_Node (TT.Indirect_Attributes);
+ TT.Indirect_Attributes := To_Access_Address (P);
+ end;
+ end if;
+
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+
+ exception
+ when others =>
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ raise;
+ end;
+
+ return;
+
+ exception
+ when Tasking_Error | Program_Error =>
+ raise;
+
+ when others =>
+ raise Program_Error;
+
+ end Set_Value;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ return Attribute
+ is
+ Result : Attribute;
+ TT : Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to get the Value of a";
+
+ begin
+ if TT = Null_ID then
+ Raise_Exception
+ (Program_Error'Identity, Error_Message & "null task");
+ end if;
+
+ if TT.Common.State = Terminated then
+ Raise_Exception
+ (Program_Error'Identity, Error_Message & "terminated task");
+ end if;
+
+ begin
+ if Local.Index /= 0 then
+ Result :=
+ To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Access).all;
+
+ else
+ declare
+ P : Access_Node;
+
+ begin
+ Defer_Abortion;
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ P := To_Access_Node (TT.Indirect_Attributes);
+ while P /= null loop
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ return To_Access_Wrapper (P.Wrapper).Value;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ Result := Initial_Value;
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+
+ exception
+ when others =>
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+ raise;
+ end;
+ end if;
+
+ return Result;
+ end;
+
+ exception
+ when Tasking_Error | Program_Error =>
+ raise;
+
+ when others =>
+ raise Program_Error;
+ end Value;
+
+-- Start of elaboration code for package Ada.Task_Attributes
+
+begin
+ -- This unchecked conversion can give warnings when alignments
+ -- are incorrect, but they will not be used in such cases anyway,
+ -- so the warnings can be safely ignored.
+
+ pragma Warnings (Off);
+ Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
+ pragma Warnings (On);
+
+ declare
+ Two_To_J : Direct_Index_Vector;
+
+ begin
+ Defer_Abortion;
+ POP.Write_Lock (All_Attrs_L'Access);
+
+ -- Add this instantiation to the list of all instantiations.
+
+ Local.Next := System.Tasking.Task_Attributes.All_Attributes;
+ System.Tasking.Task_Attributes.All_Attributes :=
+ Local'Unchecked_Access;
+
+ -- Try to find space for the attribute in the TCB.
+
+ Local.Index := 0;
+ Two_To_J := 2 ** Direct_Index'First;
+
+ if Attribute'Size <= System.Address'Size then
+ for J in Direct_Index loop
+ if (Two_To_J and In_Use) /= 0 then
+
+ -- Reserve location J for this attribute
+
+ In_Use := In_Use or Two_To_J;
+ Local.Index := J;
+
+ -- This unchecked conversions can give a warning when the
+ -- the alignment is incorrect, but it will not be used in
+ -- such a case anyway, so the warning can be safely ignored.
+
+ pragma Warnings (Off);
+ To_Attribute_Handle (Local.Initial_Value'Access).all :=
+ Initial_Value;
+ pragma Warnings (On);
+
+ exit;
+ end if;
+
+ Two_To_J := Two_To_J * 2;
+ end loop;
+ end if;
+
+ -- Need protection of All_Tasks_L for updating links to
+ -- per-task initialization and finalization routines,
+ -- in case some task is being created or terminated concurrently.
+
+ POP.Lock_All_Tasks_List;
+
+ -- Attribute goes directly in the TCB
+
+ if Local.Index /= 0 then
+
+ -- Replace stub for initialization routine
+ -- that is called at task creation.
+
+ Initialization.Initialize_Attributes_Link :=
+ System.Tasking.Task_Attributes.Initialize_Attributes'Access;
+
+ -- Initialize the attribute, for all tasks.
+
+ declare
+ C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
+
+ begin
+ while C /= null loop
+ POP.Write_Lock (C);
+ C.Direct_Attributes (Local.Index) :=
+ System.Storage_Elements.To_Address (Local.Initial_Value);
+ POP.Unlock (C);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ end;
+
+ -- Attribute goes into a node onto a linked list
+
+ else
+ -- Replace stub for finalization routine
+ -- that is called at task termination.
+
+ Initialization.Finalize_Attributes_Link :=
+ System.Tasking.Task_Attributes.Finalize_Attributes'Access;
+
+ end if;
+
+ POP.Unlock_All_Tasks_List;
+ POP.Unlock (All_Attrs_L'Access);
+ Undefer_Abortion;
+
+ exception
+ when others => null;
+ pragma Assert (Shutdown ("Exception in task attribute initializer"));
+
+ -- If we later decide to allow exceptions to propagate, we need to
+ -- not only release locks and undefer abortion, we also need to undo
+ -- any initializations that succeeded up to this point, or we will
+ -- risk a dangling reference when the task terminates.
+ end;
+
+end Ada.Task_Attributes;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T A S K _ A T T R I B U T E S --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Task_Identification;
+
+generic
+ type Attribute is private;
+ Initial_Value : in Attribute;
+
+package Ada.Task_Attributes is
+
+ type Attribute_Handle is access all Attribute;
+
+ function Value
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return Attribute;
+
+ function Reference
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return Attribute_Handle;
+
+ procedure Set_Value
+ (Val : Attribute;
+ T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task);
+
+ procedure Reinitialize
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task);
+
+private
+ pragma Inline (Value);
+ pragma Inline (Set_Value);
+ pragma Inline (Reinitialize);
+
+end Ada.Task_Attributes;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T A S K _ I D E N T I F I C A T I O N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- 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.Address_Image;
+-- used for the function itself
+
+with System.Tasking;
+-- used for Task_List
+
+with System.Tasking.Stages;
+-- used for Terminated
+-- Abort_Tasks
+
+with System.Tasking.Rendezvous;
+-- used for Callable
+
+with System.Task_Primitives.Operations;
+-- used for Self
+
+with System.Task_Info;
+use type System.Task_Info.Task_Image_Type;
+
+with Unchecked_Conversion;
+
+package body Ada.Task_Identification is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Convert_Ids (T : Task_Id) return System.Tasking.Task_ID;
+ function Convert_Ids (T : System.Tasking.Task_ID) return Task_Id;
+ pragma Inline (Convert_Ids);
+ -- Conversion functions between different forms of Task_Id
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Task_Id) return Boolean is
+ begin
+ return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right));
+ end "=";
+
+ -----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ begin
+ if T = Null_Task_Id then
+ raise Program_Error;
+ else
+ System.Tasking.Stages.Abort_Tasks
+ (System.Tasking.Task_List'(1 => Convert_Ids (T)));
+ end if;
+ end Abort_Task;
+
+ -----------------
+ -- Convert_Ids --
+ -----------------
+
+ function Convert_Ids (T : Task_Id) return System.Tasking.Task_ID is
+ begin
+ return System.Tasking.Task_ID (T);
+ end Convert_Ids;
+
+ function Convert_Ids (T : System.Tasking.Task_ID) return Task_Id is
+ begin
+ return Task_Id (T);
+ end Convert_Ids;
+
+ ------------------
+ -- Current_Task --
+ ------------------
+
+ function Current_Task return Task_Id is
+ begin
+ return Convert_Ids (System.Task_Primitives.Operations.Self);
+ end Current_Task;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (T : Task_Id) return String is
+ use System.Task_Info;
+ function To_Address is new
+ Unchecked_Conversion (Task_Id, System.Address);
+
+ begin
+ if T = Null_Task_Id then
+ return "";
+
+ elsif T.Common.Task_Image = null then
+ return System.Address_Image (To_Address (T));
+
+ else
+ return T.Common.Task_Image.all
+ & "_" & System.Address_Image (To_Address (T));
+ end if;
+ end Image;
+
+ -----------------
+ -- Is_Callable --
+ -----------------
+
+ function Is_Callable (T : Task_Id) return Boolean is
+ begin
+ if T = Null_Task_Id then
+ raise Program_Error;
+ else
+ return System.Tasking.Rendezvous.Callable (Convert_Ids (T));
+ end if;
+ end Is_Callable;
+
+ -------------------
+ -- Is_Terminated --
+ -------------------
+
+ function Is_Terminated (T : Task_Id) return Boolean is
+ begin
+ if T = Null_Task_Id then
+ raise Program_Error;
+ else
+ return System.Tasking.Stages.Terminated (Convert_Ids (T));
+ end if;
+ end Is_Terminated;
+
+end Ada.Task_Identification;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T A S K _ I D E N T I F I C A T I O N --
+-- --
+-- 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 System;
+with System.Tasking;
+
+package Ada.Task_Identification is
+
+ type Task_Id is private;
+
+ Null_Task_Id : constant Task_Id;
+
+ function "=" (Left, Right : Task_Id) return Boolean;
+ pragma Inline ("=");
+
+ function Image (T : Task_Id) return String;
+
+ function Current_Task return Task_Id;
+ pragma Inline (Current_Task);
+
+ procedure Abort_Task (T : Task_Id);
+ pragma Inline (Abort_Task);
+ -- Note: parameter is mode IN, not IN OUT, per AI-00101.
+
+ function Is_Terminated (T : Task_Id) return Boolean;
+ pragma Inline (Is_Terminated);
+
+ function Is_Callable (T : Task_Id) return Boolean;
+ pragma Inline (Is_Callable);
+
+private
+
+ type Task_Id is new System.Tasking.Task_ID;
+
+ Null_Task_ID : constant Task_Id := Task_Id (System.Tasking.Null_Task);
+
+end Ada.Task_Identification;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E D I T I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Fixed;
+package body Ada.Text_IO.Editing is
+
+ package Strings renames Ada.Strings;
+ package Strings_Fixed renames Ada.Strings.Fixed;
+ package Text_IO renames Ada.Text_IO;
+
+ ---------------------
+ -- Blank_When_Zero --
+ ---------------------
+
+ function Blank_When_Zero (Pic : in Picture) return Boolean is
+ begin
+ return Pic.Contents.Original_BWZ;
+ end Blank_When_Zero;
+
+ ------------
+ -- Expand --
+ ------------
+
+ function Expand (Picture : in String) return String is
+ Result : String (1 .. MAX_PICSIZE);
+ Picture_Index : Integer := Picture'First;
+ Result_Index : Integer := Result'First;
+ Count : Natural;
+ Last : Integer;
+
+ package Int_IO is new Ada.Text_IO.Integer_IO (Integer);
+
+ begin
+ if Picture'Length < 1 then
+ raise Picture_Error;
+ end if;
+
+ if Picture (Picture'First) = '(' then
+ raise Picture_Error;
+ end if;
+
+ loop
+ case Picture (Picture_Index) is
+
+ when '(' =>
+ Int_IO.Get (Picture (Picture_Index + 1 .. Picture'Last),
+ Count, Last);
+
+ if Picture (Last + 1) /= ')' then
+ raise Picture_Error;
+ end if;
+
+ -- In what follows note that one copy of the repeated
+ -- character has already been made, so a count of one is a
+ -- no-op, and a count of zero erases a character.
+
+ for J in 2 .. Count loop
+ Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
+ end loop;
+
+ Result_Index := Result_Index + Count - 1;
+
+ -- Last + 1 was a ')' throw it away too.
+
+ Picture_Index := Last + 2;
+
+ when ')' =>
+ raise Picture_Error;
+
+ when others =>
+ Result (Result_Index) := Picture (Picture_Index);
+ Picture_Index := Picture_Index + 1;
+ Result_Index := Result_Index + 1;
+
+ end case;
+
+ exit when Picture_Index > Picture'Last;
+ end loop;
+
+ return Result (1 .. Result_Index - 1);
+
+ exception
+ when others =>
+ raise Picture_Error;
+
+ end Expand;
+
+ -------------------
+ -- Format_Number --
+ -------------------
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : String;
+ Fill_Character : Character;
+ Separator_Character : Character;
+ Radix_Point : Character)
+ return String
+ is
+ Attrs : Number_Attributes := Parse_Number_String (Number);
+ Position : Integer;
+ Rounded : String := Number;
+
+ Sign_Position : Integer := Pic.Sign_Position; -- may float.
+
+ Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded;
+ Last : Integer;
+ Currency_Pos : Integer := Pic.Start_Currency;
+
+ Dollar : Boolean := False;
+ -- Overridden immediately if necessary.
+
+ Zero : Boolean := True;
+ -- Set to False when a non-zero digit is output.
+
+ begin
+
+ -- If the picture has fewer decimal places than the number, the image
+ -- must be rounded according to the usual rules.
+
+ if Attrs.Has_Fraction then
+ declare
+ R : constant Integer :=
+ (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
+ - Pic.Max_Trailing_Digits;
+ R_Pos : Integer;
+
+ begin
+ if R > 0 then
+ R_Pos := Attrs.End_Of_Fraction - R;
+
+ if Rounded (R_Pos + 1) > '4' then
+
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+
+ while R_Pos > 1 loop
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ exit;
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+ end if;
+ end loop;
+
+ -- The rounding may add a digit in front. Either the
+ -- leading blank or the sign (already captured) can
+ -- be overwritten.
+
+ if R_Pos = 1 then
+ Rounded (R_Pos) := '1';
+ Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Pic.Start_Currency /= Invalid_Position then
+ Dollar := Answer (Pic.Start_Currency) = '$';
+ end if;
+
+ -- Fix up "direct inserts" outside the playing field. Set up as one
+ -- loop to do the beginning, one (reverse) loop to do the end.
+
+ Last := 1;
+ loop
+ exit when Last = Pic.Start_Float;
+ exit when Last = Pic.Radix_Position;
+ exit when Answer (Last) = '9';
+
+ case Answer (Last) is
+
+ when '_' =>
+ Answer (Last) := Separator_Character;
+
+ when 'b' =>
+ Answer (Last) := ' ';
+
+ when others =>
+ null;
+
+ end case;
+
+ exit when Last = Answer'Last;
+
+ Last := Last + 1;
+ end loop;
+
+ -- Now for the end...
+
+ for J in reverse Last .. Answer'Last loop
+ exit when J = Pic.Radix_Position;
+
+ -- Do this test First, Separator_Character can equal Pic.Floater.
+
+ if Answer (J) = Pic.Floater then
+ exit;
+ end if;
+
+ case Answer (J) is
+
+ when '_' =>
+ Answer (J) := Separator_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ exit;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ -- Non-floating sign
+
+ if Pic.Start_Currency /= -1
+ and then Answer (Pic.Start_Currency) = '#'
+ and then Pic.Floater /= '#'
+ then
+ if Currency_Symbol'Length >
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ raise Picture_Error;
+
+ elsif Currency_Symbol'Length =
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ Currency_Symbol;
+
+ elsif Pic.Radix_Position = Invalid_Position
+ or else Pic.Start_Currency < Pic.Radix_Position
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
+ Pic.End_Currency) := Currency_Symbol;
+
+ else
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.Start_Currency ..
+ Pic.Start_Currency + Currency_Symbol'Length - 1) :=
+ Currency_Symbol;
+ end if;
+ end if;
+
+ -- Fill in leading digits
+
+ if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
+ Pic.Max_Leading_Digits
+ then
+ raise Layout_Error;
+ end if;
+
+ if Pic.Radix_Position = Invalid_Position then
+ Position := Answer'Last;
+ else
+ Position := Pic.Radix_Position - 1;
+ end if;
+
+ for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
+
+ while Answer (Position) /= '9'
+ and Answer (Position) /= Pic.Floater
+ loop
+ if Answer (Position) = '_' then
+ Answer (Position) := Separator_Character;
+
+ elsif Answer (Position) = 'b' then
+ Answer (Position) := ' ';
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ Answer (Position) := Rounded (J);
+
+ if Rounded (J) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ -- Do lead float
+
+ if Pic.Start_Float = Invalid_Position then
+
+ -- No leading floats, but need to change '9' to '0', '_' to
+ -- Separator_Character and 'b' to ' '.
+
+ for J in Last .. Position loop
+
+ -- Last set when fixing the "uninteresting" leaders above.
+ -- Don't duplicate the work.
+
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+ end if;
+ end loop;
+
+ elsif Pic.Floater = '<'
+ or else
+ Pic.Floater = '+'
+ or else
+ Pic.Floater = '-'
+ then
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Sign_Position := Position;
+
+ elsif Pic.Floater = '$' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := ' '; -- no separators before leftmost digit.
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Currency_Pos := Position;
+
+ elsif Pic.Floater = '*' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := '*';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position loop
+ Answer (J) := '*';
+ end loop;
+
+ else
+ if Pic.Floater = '#' then
+ Currency_Pos := Currency_Symbol'Length;
+ end if;
+
+ for J in reverse Pic.Start_Float .. Position loop
+ case Answer (J) is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' | '/' | '0' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ Answer (J) := '0';
+
+ when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
+ null;
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+ end if;
+
+ -- Do sign
+
+ if Sign_Position = Invalid_Position then
+ if Attrs.Negative then
+ raise Layout_Error;
+ end if;
+
+ else
+ if Attrs.Negative then
+ case Answer (Sign_Position) is
+ when 'C' | 'D' | '-' =>
+ null;
+
+ when '+' =>
+ Answer (Sign_Position) := '-';
+
+ when '<' =>
+ Answer (Sign_Position) := '(';
+ Answer (Pic.Second_Sign) := ')';
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ else -- positive
+
+ case Answer (Sign_Position) is
+
+ when '-' =>
+ Answer (Sign_Position) := ' ';
+
+ when '<' | 'C' | 'D' =>
+ Answer (Sign_Position) := ' ';
+ Answer (Pic.Second_Sign) := ' ';
+
+ when '+' =>
+ null;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end if;
+ end if;
+
+ -- Fill in trailing digits
+
+ if Pic.Max_Trailing_Digits > 0 then
+
+ if Attrs.Has_Fraction then
+ Position := Attrs.Start_Of_Fraction;
+ Last := Pic.Radix_Position + 1;
+
+ for J in Last .. Answer'Last loop
+
+ if Answer (J) = '9' or Answer (J) = Pic.Floater then
+ Answer (J) := Rounded (Position);
+
+ if Rounded (Position) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position + 1;
+ Last := J + 1;
+
+ -- Used up fraction but remember place in Answer
+
+ exit when Position > Attrs.End_Of_Fraction;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ end if;
+
+ Last := J + 1;
+ end loop;
+
+ Position := Last;
+
+ else
+ Position := Pic.Radix_Position + 1;
+ end if;
+
+ -- Now fill remaining 9's with zeros and _ with separators
+
+ Last := Answer'Last;
+
+ for J in Position .. Last loop
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = Pic.Floater then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+ end loop;
+
+ Position := Last + 1;
+
+ else
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+
+ -- No trailing digits, but now J may need to stick in a currency
+ -- symbol or sign.
+
+ if Pic.Start_Currency = Invalid_Position then
+ Position := Answer'Last + 1;
+ else
+ Position := Pic.Start_Currency;
+ end if;
+ end if;
+
+ for J in Position .. Answer'Last loop
+
+ if Pic.Start_Currency /= Invalid_Position and then
+ Answer (Pic.Start_Currency) = '#' then
+ Currency_Pos := 1;
+ end if;
+
+ -- Note: There are some weird cases J can imagine with 'b' or '#'
+ -- in currency strings where the following code will cause
+ -- glitches. The trick is to tell when the character in the
+ -- answer should be checked, and when to look at the original
+ -- string. Some other time. RIE 11/26/96 ???
+
+ case Answer (J) is
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'z' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ exit;
+
+ end case;
+ end loop;
+
+ -- Now get rid of Blank_when_Zero and complete Star fill.
+
+ if Zero and Pic.Blank_When_Zero then
+
+ -- Value is zero, and blank it.
+
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position and then
+ Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+ end if;
+
+ return String' (1 .. Last => ' ');
+
+ elsif Zero and Pic.Star_Fill then
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+
+ elsif Dollar then
+ if Pic.Radix_Position > Pic.Start_Currency then
+ return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ String' (Pic.Radix_Position + 1 .. Last => '*');
+
+ else
+ return
+ String'
+ (1 ..
+ Pic.Radix_Position + Currency_Symbol'Length - 2 =>
+ '*') & Radix_Point &
+ String'
+ (Pic.Radix_Position + Currency_Symbol'Length .. Last
+ => '*');
+ end if;
+
+ else
+ return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ String' (Pic.Radix_Position + 1 .. Last => '*');
+ end if;
+ end if;
+
+ return String' (1 .. Last => '*');
+ end if;
+
+ -- This was once a simple return statement, now there are nine
+ -- different return cases. Not to mention the five above to deal
+ -- with zeros. Why not split things out?
+
+ -- Processing the radix and sign expansion separately
+ -- would require lots of copying--the string and some of its
+ -- indicies--without really simplifying the logic. The cases are:
+
+ -- 1) Expand $, replace '.' with Radix_Point
+ -- 2) No currency expansion, replace '.' with Radix_Point
+ -- 3) Expand $, radix blanked
+ -- 4) No currency expansion, radix blanked
+ -- 5) Elide V
+ -- 6) Expand $, Elide V
+ -- 7) Elide V, Expand $ (Two cases depending on order.)
+ -- 8) No radix, expand $
+ -- 9) No radix, no currency expansion
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = '.' then
+ Answer (Pic.Radix_Position) := Radix_Point;
+
+ if Dollar then
+
+ -- 1) Expand $, replace '.' with Radix_Point
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 2) No currency expansion, replace '.' with Radix_Point
+
+ return Answer;
+ end if;
+
+ elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix.
+ if Dollar then
+
+ -- 3) Expand $, radix blanked
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 4) No expansion, radix blanked
+
+ return Answer;
+ end if;
+
+ -- V cases
+
+ else
+ if not Dollar then
+
+ -- 5) Elide V
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ elsif Currency_Pos < Pic.Radix_Position then
+
+ -- 6) Expand $, Elide V
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ else
+ -- 7) Elide V, Expand $
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
+ Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+ end if;
+ end if;
+
+ elsif Dollar then
+
+ -- 8) No radix, expand $
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 9) No radix, no currency expansion
+
+ return Answer;
+ end if;
+
+ end Format_Number;
+
+ -------------------------
+ -- Parse_Number_String --
+ -------------------------
+
+ function Parse_Number_String (Str : String) return Number_Attributes is
+ Answer : Number_Attributes;
+
+ begin
+ for J in Str'Range loop
+ case Str (J) is
+
+ when ' ' =>
+ null; -- ignore
+
+ when '1' .. '9' =>
+
+ -- Decide if this is the start of a number.
+ -- If so, figure out which one...
+
+ if Answer.Has_Fraction then
+ Answer.End_Of_Fraction := J;
+ else
+ if Answer.Start_Of_Int = Invalid_Position then
+ -- start integer
+ Answer.Start_Of_Int := J;
+ end if;
+ Answer.End_Of_Int := J;
+ end if;
+
+ when '0' =>
+
+ -- Only count a zero before the decimal point if it follows a
+ -- non-zero digit. After the decimal point, zeros will be
+ -- counted if followed by a non-zero digit.
+
+ if not Answer.Has_Fraction then
+ if Answer.Start_Of_Int /= Invalid_Position then
+ Answer.End_Of_Int := J;
+ end if;
+ end if;
+
+ when '-' =>
+
+ -- Set negative
+
+ Answer.Negative := True;
+
+ when '.' =>
+
+ -- Close integer, start fraction
+
+ if Answer.Has_Fraction then
+ raise Picture_Error;
+ end if;
+
+ -- Two decimal points is a no-no.
+
+ Answer.Has_Fraction := True;
+ Answer.End_Of_Fraction := J;
+
+ -- Could leave this at Invalid_Position, but this seems the
+ -- right way to indicate a null range...
+
+ Answer.Start_Of_Fraction := J + 1;
+ Answer.End_Of_Int := J - 1;
+
+ when others =>
+ raise Picture_Error; -- can this happen? probably not!
+ end case;
+ end loop;
+
+ if Answer.Start_Of_Int = Invalid_Position then
+ Answer.Start_Of_Int := Answer.End_Of_Int + 1;
+ end if;
+
+ -- No significant (intger) digits needs a null range.
+
+ return Answer;
+
+ end Parse_Number_String;
+
+ ----------------
+ -- Pic_String --
+ ----------------
+
+ -- The following ensures that we return B and not b being careful not
+ -- to break things which expect lower case b for blank. See CXF3A02.
+
+ function Pic_String (Pic : in Picture) return String is
+ Temp : String (1 .. Pic.Contents.Picture.Length) :=
+ Pic.Contents.Picture.Expanded;
+ begin
+ for J in Temp'Range loop
+ if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ end loop;
+
+ return Temp;
+ end Pic_String;
+
+ ------------------
+ -- Precalculate --
+ ------------------
+
+ procedure Precalculate (Pic : in out Format_Record) is
+
+ Computed_BWZ : Boolean := True;
+ Debug : Boolean := False;
+
+ type Legality is (Okay, Reject);
+ State : Legality := Reject;
+ -- Start in reject, which will reject null strings.
+
+ Index : Pic_Index := Pic.Picture.Expanded'First;
+
+ function At_End return Boolean;
+ pragma Inline (At_End);
+
+ procedure Set_State (L : Legality);
+ pragma Inline (Set_State);
+
+ function Look return Character;
+ pragma Inline (Look);
+
+ function Is_Insert return Boolean;
+ pragma Inline (Is_Insert);
+
+ procedure Skip;
+ pragma Inline (Skip);
+
+ procedure Debug_Start (Name : String);
+ pragma Inline (Debug_Start);
+
+ procedure Debug_Integer (Value : in Integer; S : String);
+ pragma Inline (Debug_Integer);
+
+ procedure Trailing_Currency;
+ procedure Trailing_Bracket;
+ procedure Number_Fraction;
+ procedure Number_Completion;
+ procedure Number_Fraction_Or_Bracket;
+ procedure Number_Fraction_Or_Z_Fill;
+ procedure Zero_Suppression;
+ procedure Floating_Bracket;
+ procedure Number_Fraction_Or_Star_Fill;
+ procedure Star_Suppression;
+ procedure Number_Fraction_Or_Dollar;
+ procedure Leading_Dollar;
+ procedure Number_Fraction_Or_Pound;
+ procedure Leading_Pound;
+ procedure Picture;
+ procedure Floating_Plus;
+ procedure Floating_Minus;
+ procedure Picture_Plus;
+ procedure Picture_Minus;
+ procedure Picture_Bracket;
+ procedure Number;
+ procedure Optional_RHS_Sign;
+ procedure Picture_String;
+
+ ------------
+ -- At_End --
+ ------------
+
+ function At_End return Boolean is
+ begin
+ return Index > Pic.Picture.Length;
+ end At_End;
+
+ -------------------
+ -- Debug_Integer --
+ -------------------
+
+ procedure Debug_Integer (Value : in Integer; S : String) is
+ use Ada.Text_IO; -- needed for >
+
+ begin
+ if Debug and then Value > 0 then
+ if Ada.Text_IO.Col > 70 - S'Length then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ',');
+ end if;
+ end Debug_Integer;
+
+ -----------------
+ -- Debug_Start --
+ -----------------
+
+ procedure Debug_Start (Name : String) is
+ begin
+ if Debug then
+ Ada.Text_IO.Put_Line (" In " & Name & '.');
+ end if;
+ end Debug_Start;
+
+ ----------------------
+ -- Floating_Bracket --
+ ----------------------
+
+ -- Note that Floating_Bracket is only called with an acceptable
+ -- prefix. But we don't set Okay, because we must end with a '>'.
+
+ procedure Floating_Bracket is
+ begin
+ Debug_Start ("Floating_Bracket");
+ Pic.Floater := '<';
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+
+ -- First bracket wasn't counted...
+
+ Skip; -- known '<'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+
+ when '$' =>
+ Leading_Dollar;
+
+ when '#' =>
+ Leading_Pound;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Bracket;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Bracket;
+
+
+ --------------------
+ -- Floating_Minus --
+ --------------------
+
+ procedure Floating_Minus is
+ begin
+ Debug_Start ("Floating_Minus");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '-' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '-' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Minus;
+
+ -------------------
+ -- Floating_Plus --
+ -------------------
+
+ procedure Floating_Plus is
+ begin
+ Debug_Start ("Floating_Plus");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '+' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Floating_Plus;
+
+ ---------------
+ -- Is_Insert --
+ ---------------
+
+ function Is_Insert return Boolean is
+ begin
+ if At_End then
+ return False;
+ end if;
+
+ case Pic.Picture.Expanded (Index) is
+
+ when '_' | '0' | '/' => return True;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b'; -- canonical
+ return True;
+
+ when others => return False;
+ end case;
+ end Is_Insert;
+
+ --------------------
+ -- Leading_Dollar --
+ --------------------
+
+ -- Note that Leading_Dollar can be called in either State.
+ -- It will set state to Okay only if a 9 or (second) $
+ -- is encountered.
+
+ -- Also notice the tricky bit with State and Zero_Suppression.
+ -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
+ -- encountered, exactly the cases where State has been set.
+
+ procedure Leading_Dollar is
+ begin
+ Debug_Start ("Leading_Dollar");
+
+ -- Treat as a floating dollar, and unwind otherwise.
+
+ Pic.Floater := '$';
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Skip; -- known '$'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ -- A trailing insertion character is not part of the
+ -- floating currency, so need to look ahead.
+
+ if Look /= '$' then
+ Pic.End_Float := Pic.End_Float - 1;
+ end if;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '$' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- A single dollar does not a floating make.
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one dollar before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Dollar;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Leading_Dollar;
+
+ -------------------
+ -- Leading_Pound --
+ -------------------
+
+ -- This one is complex! A Leading_Pound can be fixed or floating,
+ -- but in some cases the decision has to be deferred until we leave
+ -- this procedure. Also note that Leading_Pound can be called in
+ -- either State.
+
+ -- It will set state to Okay only if a 9 or (second) # is
+ -- encountered.
+
+ -- One Last note: In ambiguous cases, the currency is treated as
+ -- floating unless there is only one '#'.
+
+ procedure Leading_Pound is
+
+ Inserts : Boolean := False;
+ -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
+
+ Must_Float : Boolean := False;
+ -- Set to true if a '#' occurs after an insert.
+
+ begin
+ Debug_Start ("Leading_Pound");
+
+ -- Treat as a floating currency. If it isn't, this will be
+ -- overwritten later.
+
+ Pic.Floater := '#';
+
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Pic.Max_Currency_Digits := 1; -- we've seen one.
+
+ Skip; -- known '#'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '#' =>
+ if Inserts then
+ Must_Float := True;
+ end if;
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ if State /= Okay then
+
+ -- A single '#' doesn't float.
+
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one pound before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Pound;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Leading_Pound;
+
+ ----------
+ -- Look --
+ ----------
+
+ function Look return Character is
+ begin
+ if At_End then
+ raise Picture_Error;
+ end if;
+
+ return Pic.Picture.Expanded (Index);
+ end Look;
+
+ ------------
+ -- Number --
+ ------------
+
+ procedure Number is
+ begin
+ Debug_Start ("Number");
+
+ loop
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+
+ if At_End then
+ return;
+ end if;
+
+ -- Will return in Okay state if a '9' was seen.
+
+ end loop;
+ end Number;
+
+ -----------------------
+ -- Number_Completion --
+ -----------------------
+
+ procedure Number_Completion is
+ begin
+ Debug_Start ("Number_Completion");
+
+ while not At_End loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Completion;
+
+ ---------------------
+ -- Number_Fraction --
+ ---------------------
+
+ procedure Number_Fraction is
+ begin
+ -- Note that number fraction can be called in either State.
+ -- It will set state to Valid only if a 9 is encountered.
+
+ Debug_Start ("Number_Fraction");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Fraction;
+
+ --------------------------------
+ -- Number_Fraction_Or_Bracket --
+ --------------------------------
+
+ procedure Number_Fraction_Or_Bracket is
+ begin
+ Debug_Start ("Number_Fraction_Or_Bracket");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Bracket;
+
+ -------------------------------
+ -- Number_Fraction_Or_Dollar --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Dollar is
+ begin
+ Debug_Start ("Number_Fraction_Or_Dollar");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Dollar;
+
+ ------------------------------
+ -- Number_Fraction_Or_Pound --
+ ------------------------------
+
+ procedure Number_Fraction_Or_Pound is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Pound;
+
+ ----------------------------------
+ -- Number_Fraction_Or_Star_Fill --
+ ----------------------------------
+
+ procedure Number_Fraction_Or_Star_Fill is
+ begin
+ Debug_Start ("Number_Fraction_Or_Star_Fill");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Star_Fill;
+
+ -------------------------------
+ -- Number_Fraction_Or_Z_Fill --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Z_Fill is
+ begin
+ Debug_Start ("Number_Fraction_Or_Z_Fill");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Z_Fill;
+
+ -----------------------
+ -- Optional_RHS_Sign --
+ -----------------------
+
+ procedure Optional_RHS_Sign is
+ begin
+ Debug_Start ("Optional_RHS_Sign");
+
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' | '-' =>
+ Pic.Sign_Position := Index;
+ Skip;
+ return;
+
+ when 'C' | 'c' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'C';
+ Skip;
+
+ if Look = 'R' or Look = 'r' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'R';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when 'D' | 'd' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'D';
+ Skip;
+
+ if Look = 'B' or Look = 'b' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'B';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when '>' =>
+ if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
+ Pic.Second_Sign := Index;
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ when others =>
+ return;
+
+ end case;
+ end Optional_RHS_Sign;
+
+ -------------
+ -- Picture --
+ -------------
+
+ -- Note that Picture can be called in either State.
+
+ -- It will set state to Valid only if a 9 is encountered or floating
+ -- currency is called.
+
+ procedure Picture is
+ begin
+ Debug_Start ("Picture");
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Leading_Dollar;
+ return;
+
+ when '#' =>
+ Leading_Pound;
+ return;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Set_State (Okay);
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ Trailing_Currency;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture;
+
+ ---------------------
+ -- Picture_Bracket --
+ ---------------------
+
+ procedure Picture_Bracket is
+ begin
+ Pic.Sign_Position := Index;
+ Debug_Start ("Picture_Bracket");
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '<';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Bracket
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Set_State (Okay); -- "<<>" is enough.
+ Floating_Bracket;
+ Trailing_Currency;
+ Trailing_Bracket;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Trailing_Bracket;
+ Set_State (Okay);
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit
+
+ Picture;
+ Trailing_Bracket;
+ return;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end loop;
+ end Picture_Bracket;
+
+ -------------------
+ -- Picture_Minus --
+ -------------------
+
+ procedure Picture_Minus is
+ begin
+ Debug_Start ("Picture_Minus");
+
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '-';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Minus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "-- " is enough.
+ Floating_Minus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+
+ -- Can't have Z and a floating sign.
+
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Minus;
+
+ ------------------
+ -- Picture_Plus --
+ ------------------
+
+ procedure Picture_Plus is
+ begin
+ Debug_Start ("Picture_Plus");
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '+';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Plus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "++" is enough.
+ Floating_Plus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ -- Can't have Z and a floating sign.
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ -- '+Z' is acceptable
+
+ Set_State (Okay);
+
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Plus;
+
+ --------------------
+ -- Picture_String --
+ --------------------
+
+ procedure Picture_String is
+ begin
+ Debug_Start ("Picture_String");
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ case Look is
+
+ when '$' | '#' =>
+ Picture;
+ Optional_RHS_Sign;
+
+ when '+' =>
+ Picture_Plus;
+
+ when '-' =>
+ Picture_Minus;
+
+ when '<' =>
+ Picture_Bracket;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '*' =>
+ Star_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '9' | '.' | 'V' | 'v' =>
+ Number;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ -- Blank when zero either if the PIC does not contain a '9' or if
+ -- requested by the user and no '*'
+
+ Pic.Blank_When_Zero :=
+ (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
+
+ -- Star fill if '*' and no '9'.
+
+ Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
+
+ if not At_End then
+ Set_State (Reject);
+ end if;
+
+ end Picture_String;
+
+ ---------------
+ -- Set_State --
+ ---------------
+
+ procedure Set_State (L : Legality) is
+ begin
+ if Debug then Ada.Text_IO.Put_Line
+ (" Set state from " & Legality'Image (State) &
+ " to " & Legality'Image (L));
+ end if;
+
+ State := L;
+ end Set_State;
+
+ ----------
+ -- Skip --
+ ----------
+
+ procedure Skip is
+ begin
+ if Debug then Ada.Text_IO.Put_Line
+ (" Skip " & Pic.Picture.Expanded (Index));
+ end if;
+
+ Index := Index + 1;
+ end Skip;
+
+ ----------------------
+ -- Star_Suppression --
+ ----------------------
+
+ procedure Star_Suppression is
+ begin
+ Debug_Start ("Star_Suppression");
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+
+ -- Even a single * is a valid picture
+
+ Pic.Star_Fill := True;
+ Skip; -- Known *
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Star_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others => raise Picture_Error;
+ end case;
+ end loop;
+ end Star_Suppression;
+
+ ----------------------
+ -- Trailing_Bracket --
+ ----------------------
+
+ procedure Trailing_Bracket is
+ begin
+ Debug_Start ("Trailing_Bracket");
+
+ if Look = '>' then
+ Pic.Second_Sign := Index;
+ Skip;
+ else
+ raise Picture_Error;
+ end if;
+ end Trailing_Bracket;
+
+ -----------------------
+ -- Trailing_Currency --
+ -----------------------
+
+ procedure Trailing_Currency is
+ begin
+ Debug_Start ("Trailing_Currency");
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '$' then
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Skip;
+
+ else
+ while not At_End and then Look = '#' loop
+ if Pic.Start_Currency = Invalid_Position then
+ Pic.Start_Currency := Index;
+ end if;
+
+ Pic.End_Currency := Index;
+ Skip;
+ end loop;
+ end if;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others => return;
+ end case;
+ end loop;
+ end Trailing_Currency;
+
+ ----------------------
+ -- Zero_Suppression --
+ ----------------------
+
+ procedure Zero_Suppression is
+ begin
+ Debug_Start ("Zero_Suppression");
+
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip; -- Known Z
+
+ loop
+ -- Even a single Z is a valid picture
+
+ if At_End then
+ Set_State (Okay);
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Z_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Zero_Suppression;
+
+ -- Start of processing for Precalculate
+
+ begin
+ Picture_String;
+
+ if Debug then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put (" Picture : """ &
+ Pic.Picture.Expanded (1 .. Pic.Picture.Length) & """,");
+ Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',");
+ end if;
+
+ if State = Reject then
+ raise Picture_Error;
+ end if;
+
+ Debug_Integer (Pic.Radix_Position, "Radix Positon : ");
+ Debug_Integer (Pic.Sign_Position, "Sign Positon : ");
+ Debug_Integer (Pic.Second_Sign, "Second Sign : ");
+ Debug_Integer (Pic.Start_Float, "Start Float : ");
+ Debug_Integer (Pic.End_Float, "End Float : ");
+ Debug_Integer (Pic.Start_Currency, "Start Currency : ");
+ Debug_Integer (Pic.End_Currency, "End Currency : ");
+ Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : ");
+ Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : ");
+
+ if Debug then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ exception
+
+ when Constraint_Error =>
+
+ -- To deal with special cases like null strings.
+
+ raise Picture_Error;
+
+ end Precalculate;
+
+ ----------------
+ -- To_Picture --
+ ----------------
+
+ function To_Picture
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Picture
+ is
+ Result : Picture;
+
+ begin
+ declare
+ Item : constant String := Expand (Pic_String);
+
+ begin
+ Result.Contents.Picture := (Item'Length, Item);
+ Result.Contents.Original_BWZ := Blank_When_Zero;
+ Result.Contents.Blank_When_Zero := Blank_When_Zero;
+ Precalculate (Result.Contents);
+ return Result;
+ end;
+
+ exception
+ when others =>
+ raise Picture_Error;
+
+ end To_Picture;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Boolean
+ is
+ begin
+ declare
+ Expanded_Pic : constant String := Expand (Pic_String);
+ -- Raises Picture_Error if Item not well-formed
+
+ Format_Rec : Format_Record;
+
+ begin
+ Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
+ Format_Rec.Blank_When_Zero := Blank_When_Zero;
+ Format_Rec.Original_BWZ := Blank_When_Zero;
+ Precalculate (Format_Rec);
+
+ -- False only if Blank_When_0 is True but the pic string has a '*'
+
+ return not Blank_When_Zero or
+ Strings_Fixed.Index (Expanded_Pic, "*") = 0;
+ end;
+
+ exception
+ when others => return False;
+
+ end Valid;
+
+ --------------------
+ -- Decimal_Output --
+ --------------------
+
+ package body Decimal_Output is
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image
+ (Item : in Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark)
+ return String
+ is
+ begin
+ return Format_Number
+ (Pic.Contents, Num'Image (Item),
+ Currency, Fill, Separator, Radix_Mark);
+ end Image;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length
+ (Pic : in Picture;
+ Currency : in String := Default_Currency)
+ return Natural
+ is
+ Picstr : constant String := Pic_String (Pic);
+ V_Adjust : Integer := 0;
+ Cur_Adjust : Integer := 0;
+
+ begin
+ -- Check if Picstr has 'V' or '$'
+
+ -- If 'V', then length is 1 less than otherwise
+
+ -- If '$', then length is Currency'Length-1 more than otherwise
+
+ -- This should use the string handling package ???
+
+ for J in Picstr'Range loop
+ if Picstr (J) = 'V' then
+ V_Adjust := -1;
+
+ elsif Picstr (J) = '$' then
+ Cur_Adjust := Currency'Length - 1;
+ end if;
+ end loop;
+
+ return Picstr'Length - V_Adjust + Cur_Adjust;
+ end Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in Text_IO.File_Type;
+ Item : in Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark)
+ is
+ begin
+ Text_IO.Put (File, Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark)
+ is
+ begin
+ Text_IO.Put (Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark)
+ is
+ Result : constant String :=
+ Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
+
+ begin
+ if Result'Length > To'Length then
+ raise Text_IO.Layout_Error;
+ else
+ Strings_Fixed.Move (Source => Result, Target => To,
+ Justify => Strings.Right);
+ end if;
+ end Put;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency)
+ return Boolean
+ is
+ begin
+ declare
+ Temp : constant String := Image (Item, Pic, Currency);
+ pragma Warnings (Off, Temp);
+ begin
+ return True;
+ end;
+
+ exception
+ when Layout_Error => return False;
+
+ end Valid;
+
+ end Decimal_Output;
+
+end Ada.Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E D I T I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- 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.Text_IO.Editing is
+
+ type Picture is private;
+
+ function Valid
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Boolean;
+
+ function To_Picture
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Picture;
+
+ function Pic_String (Pic : in Picture) return String;
+ function Blank_When_Zero (Pic : in Picture) return Boolean;
+
+ Max_Picture_Length : constant := 64;
+
+ Picture_Error : exception;
+
+ Default_Currency : constant String := "$";
+ Default_Fill : constant Character := ' ';
+ Default_Separator : constant Character := ',';
+ Default_Radix_Mark : constant Character := '.';
+
+ generic
+ type Num is delta <> digits <>;
+ Default_Currency : in String := Editing.Default_Currency;
+ Default_Fill : in Character := Editing.Default_Fill;
+ Default_Separator : in Character := Editing.Default_Separator;
+ Default_Radix_Mark : in Character := Editing.Default_Radix_Mark;
+
+ package Decimal_Output is
+
+ function Length
+ (Pic : in Picture;
+ Currency : in String := Default_Currency)
+ return Natural;
+
+ function Valid
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency)
+ return Boolean;
+
+ function Image
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark)
+ return String;
+
+ procedure Put
+ (File : in Ada.Text_IO.File_Type;
+ Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark);
+
+ procedure Put
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark);
+
+ procedure Put
+ (To : out String;
+ Item : Num;
+ Pic : in Picture;
+ Currency : in String := Default_Currency;
+ Fill : in Character := Default_Fill;
+ Separator : in Character := Default_Separator;
+ Radix_Mark : in Character := Default_Radix_Mark);
+
+ end Decimal_Output;
+
+private
+
+ MAX_PICSIZE : constant := 50;
+ MAX_MONEYSIZE : constant := 10;
+ Invalid_Position : constant := -1;
+
+ subtype Pic_Index is Natural range 0 .. MAX_PICSIZE;
+
+ type Picture_Record (Length : Pic_Index := 0) is record
+ Expanded : String (1 .. Length);
+ end record;
+
+ type Format_Record is record
+ Picture : Picture_Record;
+ -- Read only
+
+ Blank_When_Zero : Boolean;
+ -- Read/write
+
+ Original_BWZ : Boolean;
+
+ -- The following components get written
+
+ Star_Fill : Boolean := False;
+
+ Radix_Position : Integer := Invalid_Position;
+
+ Sign_Position,
+ Second_Sign : Integer := Invalid_Position;
+
+ Start_Float,
+ End_Float : Integer := Invalid_Position;
+
+ Start_Currency,
+ End_Currency : Integer := Invalid_Position;
+
+ Max_Leading_Digits : Integer := 0;
+
+ Max_Trailing_Digits : Integer := 0;
+
+ Max_Currency_Digits : Integer := 0;
+
+ Floater : Character := '!';
+ -- Initialized to illegal value
+
+ end record;
+
+ type Picture is record
+ Contents : Format_Record;
+ end record;
+
+ type Number_Attributes is record
+ Negative : Boolean := False;
+
+ Has_Fraction : Boolean := False;
+
+ Start_Of_Int,
+ End_Of_Int,
+ Start_Of_Fraction,
+ End_Of_Fraction : Integer := Invalid_Position; -- invalid value
+ end record;
+
+ function Parse_Number_String (Str : String) return Number_Attributes;
+ -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no
+ -- trailing blanks...)
+
+ procedure Precalculate (Pic : in out Format_Record);
+ -- Precalculates fields from the user supplied data
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : String;
+ Fill_Character : Character;
+ Separator_Character : Character;
+ Radix_Point : Character)
+ return String;
+ -- Formats number according to Pic
+
+ function Expand (Picture : in String) return String;
+
+end Ada.Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.81 $
+-- --
+-- 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.Streams; use Ada.Streams;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System;
+with System.File_IO;
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+pragma Elaborate_All (System.File_IO);
+-- Needed because of calls to Chain_File in package body elaboration
+
+package body Ada.Text_IO is
+
+ package FIO renames System.File_IO;
+
+ subtype AP is FCB.AFCB_Ptr;
+
+ function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
+ function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+ use type FCB.File_Mode;
+
+ -------------------
+ -- AFCB_Allocate --
+ -------------------
+
+ function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
+ begin
+ return new Text_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ procedure AFCB_Close (File : access Text_AFCB) is
+ begin
+ -- If the file being closed is one of the current files, then close
+ -- the corresponding current file. It is not clear that this action
+ -- is required (RM A.10.3(23)) but it seems reasonable, and besides
+ -- ACVC test CE3208A expects this behavior.
+
+ if File_Type (File) = Current_In then
+ Current_In := null;
+ elsif File_Type (File) = Current_Out then
+ Current_Out := null;
+ elsif File_Type (File) = Current_Err then
+ Current_Err := null;
+ end if;
+
+ Terminate_Line (File_Type (File));
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Text_AFCB) is
+ type FCB_Ptr is access all Text_AFCB;
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new Unchecked_Deallocation (Text_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out File_Type) is
+ begin
+ FIO.Close (AP (File));
+ end Close;
+
+ ---------
+ -- Col --
+ ---------
+
+ -- Note: we assume that it is impossible in practice for the column
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Col (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Col;
+ end Col;
+
+ function Col return Positive_Count is
+ begin
+ return Col (Current_Out);
+ end Col;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : in File_Mode := Out_File;
+ Name : in String := "";
+ Form : in String := "")
+ is
+ File_Control_Block : Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'T',
+ Creat => True,
+ Text => True);
+
+ File.Self := File;
+ end Create;
+
+ -------------------
+ -- Current_Error --
+ -------------------
+
+ function Current_Error return File_Type is
+ begin
+ return Current_Err;
+ end Current_Error;
+
+ function Current_Error return File_Access is
+ begin
+ return Current_Err.Self'Access;
+ end Current_Error;
+
+ -------------------
+ -- Current_Input --
+ -------------------
+
+ function Current_Input return File_Type is
+ begin
+ return Current_In;
+ end Current_Input;
+
+ function Current_Input return File_Access is
+ begin
+ return Current_In.Self'Access;
+ end Current_Input;
+
+ --------------------
+ -- Current_Output --
+ --------------------
+
+ function Current_Output return File_Type is
+ begin
+ return Current_Out;
+ end Current_Output;
+
+ function Current_Output return File_Access is
+ begin
+ return Current_Out.Self'Access;
+ end Current_Output;
+
+ ------------
+ -- 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
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+
+ if File.Before_LM_PM then
+ return Nextc (File) = EOF;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Before_LM_PM := True;
+ return Nextc (File) = EOF;
+
+ -- Here if neither EOF nor PM followed end of line
+
+ else
+ Ungetc (ch, File);
+ return False;
+ end if;
+
+ end End_Of_File;
+
+ function End_Of_File return Boolean is
+ begin
+ return End_Of_File (Current_In);
+ end End_Of_File;
+
+ -----------------
+ -- End_Of_Line --
+ -----------------
+
+ function End_Of_Line (File : in File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ return True;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ else
+ Ungetc (ch, File);
+ return (ch = LM);
+ end if;
+ end if;
+ end End_Of_Line;
+
+ function End_Of_Line return Boolean is
+ begin
+ return End_Of_Line (Current_In);
+ end End_Of_Line;
+
+ -----------------
+ -- End_Of_Page --
+ -----------------
+
+ function End_Of_Page (File : in File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if not File.Is_Regular_File then
+ return False;
+
+ elsif File.Before_LM then
+ if File.Before_LM_PM then
+ return True;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Nextc (File);
+
+ return ch = PM or else ch = EOF;
+ end End_Of_Page;
+
+ function End_Of_Page return Boolean is
+ begin
+ return End_Of_Page (Current_In);
+ end End_Of_Page;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : in File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
+ procedure Flush is
+ begin
+ Flush (Current_Out);
+ end Flush;
+
+ ----------
+ -- Form --
+ ----------
+
+ function Form (File : in File_Type) return String is
+ begin
+ return FIO.Form (AP (File));
+ end Form;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Character)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Col := 1;
+
+ if File.Before_LM_PM then
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ File.Before_LM_PM := False;
+ else
+ File.Line := File.Line + 1;
+ end if;
+ end if;
+
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+
+ else
+ Item := Character'Val (ch);
+ File.Col := File.Col + 1;
+ return;
+ end if;
+ end loop;
+ end Get;
+
+ procedure Get (Item : out Character) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out String)
+ is
+ ch : int;
+ J : Natural;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Col := 1;
+
+ if File.Before_LM_PM then
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ File.Before_LM_PM := False;
+
+ else
+ File.Line := File.Line + 1;
+ end if;
+ end if;
+
+ J := Item'First;
+ while J <= Item'Last loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+
+ else
+ Item (J) := Character'Val (ch);
+ J := J + 1;
+ File.Col := File.Col + 1;
+ end if;
+ end loop;
+ end Get;
+
+ procedure Get (Item : out String) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ -------------------
+ -- Get_Immediate --
+ -------------------
+
+ -- More work required here ???
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Character)
+ is
+ ch : int;
+ end_of_file : int;
+
+ procedure getc_immediate
+ (stream : FILEs; ch : out int; end_of_file : out int);
+ pragma Import (C, getc_immediate, "getc_immediate");
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := LM;
+
+ else
+ getc_immediate (File.Stream, ch, end_of_file);
+
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ elsif end_of_file /= 0 then
+ raise End_Error;
+ end if;
+ end if;
+
+ Item := Character'Val (ch);
+
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Character)
+ is
+ begin
+ Get_Immediate (Current_In, Item);
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Character;
+ Available : out Boolean)
+ is
+ ch : int;
+ end_of_file : int;
+ avail : int;
+
+ procedure getc_immediate_nowait
+ (stream : FILEs;
+ ch : out int;
+ end_of_file : out int;
+ avail : out int);
+ pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait");
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are logically before an end of line, but physically after it,
+ -- then we just return the end of line character, no I/O is necessary.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ Available := True;
+ Item := Character'Val (LM);
+
+ -- Normal case where a read operation is required
+
+ else
+ getc_immediate_nowait (File.Stream, ch, end_of_file, avail);
+
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+
+ elsif end_of_file /= 0 then
+ raise End_Error;
+
+ elsif avail = 0 then
+ Available := False;
+ Item := ASCII.NUL;
+
+ else
+ Available := True;
+ Item := Character'Val (ch);
+ end if;
+ end if;
+
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Character;
+ Available : out Boolean)
+ is
+ begin
+ Get_Immediate (Current_In, Item, Available);
+ end Get_Immediate;
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ procedure Get_Line
+ (File : in File_Type;
+ Item : out String;
+ Last : out Natural)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Last := Item'First - 1;
+
+ -- Immediate exit for null string, this is a case in which we do not
+ -- need to test for end of file and we do not skip a line mark under
+ -- any circumstances.
+
+ if Last >= Item'Last then
+ return;
+ end if;
+
+ -- Here we have at least one character, if we are immediately before
+ -- a line mark, then we will just skip past it storing no characters.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ -- Otherwise we need to read some characters
+
+ else
+ ch := Getc (File);
+
+ -- If we are at the end of file now, it means we are trying to
+ -- skip a file terminator and we raise End_Error (RM A.10.7(20))
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+
+ -- Loop through characters. Don't bother if we hit a page mark,
+ -- since in normal files, page marks can only follow line marks
+ -- in any case and we only promise to treat the page nonsense
+ -- correctly in the absense of such rogue page marks.
+
+ loop
+ -- Exit the loop if read is terminated by encountering line mark
+
+ exit when ch = LM;
+
+ -- Otherwise store the character, note that we know that ch is
+ -- something other than LM or EOF. It could possibly be a page
+ -- mark if there is a stray page mark in the middle of a line,
+ -- but this is not an official page mark in any case, since
+ -- official page marks can only follow a line mark. The whole
+ -- page business is pretty much nonsense anyway, so we do not
+ -- want to waste time trying to make sense out of non-standard
+ -- page marks in the file! This means that the behavior of
+ -- Get_Line is different from repeated Get of a character, but
+ -- that's too bad. We only promise that page numbers etc make
+ -- sense if the file is formatted in a standard manner.
+
+ -- Note: we do not adjust the column number because it is quicker
+ -- to adjust it once at the end of the operation than incrementing
+ -- it each time around the loop.
+
+ Last := Last + 1;
+ Item (Last) := Character'Val (ch);
+
+ -- All done if the string is full, this is the case in which
+ -- we do not skip the following line mark. We need to adjust
+ -- the column number in this case.
+
+ if Last = Item'Last then
+ File.Col := File.Col + Count (Item'Length);
+ return;
+ end if;
+
+ -- Otherwise read next character. We also exit from the loop if
+ -- we read an end of file. This is the case where the last line
+ -- is not terminated with a line mark, and we consider that there
+ -- is an implied line mark in this case (this is a non-standard
+ -- file, but it is nice to treat it reasonably).
+
+ ch := Getc (File);
+ exit when ch = EOF;
+ end loop;
+ end if;
+
+ -- We have skipped past, but not stored, a line mark. Skip following
+ -- page mark if one follows, but do not do this for a non-regular
+ -- file (since otherwise we get annoying wait for an extra character)
+
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ if File.Before_LM_PM then
+ File.Line := 1;
+ File.Before_LM_PM := False;
+ File.Page := File.Page + 1;
+
+ elsif File.Is_Regular_File then
+ ch := Getc (File);
+
+ if ch = PM and then File.Is_Regular_File then
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+ end Get_Line;
+
+ procedure Get_Line
+ (Item : out String;
+ Last : out Natural)
+ is
+ begin
+ Get_Line (Current_In, Item, Last);
+ end Get_Line;
+
+ ----------
+ -- Getc --
+ ----------
+
+ function Getc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF and then ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ else
+ return ch;
+ end if;
+ end Getc;
+
+ -------------
+ -- Is_Open --
+ -------------
+
+ function Is_Open (File : in File_Type) return Boolean is
+ begin
+ return FIO.Is_Open (AP (File));
+ end Is_Open;
+
+ ----------
+ -- Line --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the line
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Line (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Line;
+ end Line;
+
+ function Line return Positive_Count is
+ begin
+ return Line (Current_Out);
+ end Line;
+
+ -----------------
+ -- Line_Length --
+ -----------------
+
+ function Line_Length (File : in File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Line_Length;
+ end Line_Length;
+
+ function Line_Length return Count is
+ begin
+ return Line_Length (Current_Out);
+ end Line_Length;
+
+ ----------------
+ -- Look_Ahead --
+ ----------------
+
+ procedure Look_Ahead
+ (File : in File_Type;
+ Item : out Character;
+ End_Of_Line : out Boolean)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ End_Of_Line := True;
+ Item := ASCII.NUL;
+
+ else
+ ch := Nextc (File);
+
+ if ch = LM
+ or else ch = EOF
+ or else (ch = PM and then File.Is_Regular_File)
+ then
+ End_Of_Line := True;
+ Item := ASCII.NUL;
+ else
+ End_Of_Line := False;
+ Item := Character'Val (ch);
+ end if;
+ end if;
+ end Look_Ahead;
+
+ procedure Look_Ahead
+ (Item : out Character;
+ End_Of_Line : out Boolean)
+ is
+ begin
+ Look_Ahead (Current_In, Item, End_Of_Line);
+ end Look_Ahead;
+
+ ----------
+ -- Mode --
+ ----------
+
+ function Mode (File : in File_Type) return File_Mode is
+ begin
+ return To_TIO (FIO.Mode (AP (File)));
+ end Mode;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (File : in File_Type) return String is
+ begin
+ return FIO.Name (AP (File));
+ end Name;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line
+ (File : in File_Type;
+ Spacing : in Positive_Count := 1)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+
+ for K in 1 .. Spacing loop
+ Putc (LM, File);
+ File.Line := File.Line + 1;
+
+ if File.Page_Length /= 0
+ and then File.Line > File.Page_Length
+ then
+ Putc (PM, File);
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ end if;
+ end loop;
+
+ File.Col := 1;
+ end New_Line;
+
+ procedure New_Line (Spacing : in Positive_Count := 1) is
+ begin
+ New_Line (Current_Out, Spacing);
+ end New_Line;
+
+ --------------
+ -- New_Page --
+ --------------
+
+ procedure New_Page (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Col /= 1 or else File.Line = 1 then
+ Putc (LM, File);
+ end if;
+
+ Putc (PM, File);
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ end New_Page;
+
+ procedure New_Page is
+ begin
+ New_Page (Current_Out);
+ end New_Page;
+
+ -----------
+ -- Nextc --
+ -----------
+
+ function Nextc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+
+ else
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+
+ return ch;
+ end Nextc;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : in File_Mode;
+ Name : in String;
+ Form : in String := "")
+ is
+ File_Control_Block : Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'T',
+ Creat => False,
+ Text => True);
+
+ File.Self := File;
+ end Open;
+
+ ----------
+ -- Page --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the page
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Page (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Page;
+ end Page;
+
+ function Page return Positive_Count is
+ begin
+ return Page (Current_Out);
+ end Page;
+
+ -----------------
+ -- Page_Length --
+ -----------------
+
+ function Page_Length (File : in File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Page_Length;
+ end Page_Length;
+
+ function Page_Length return Count is
+ begin
+ return Page_Length (Current_Out);
+ end Page_Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Character)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Line_Length /= 0 and then File.Col > File.Line_Length then
+ New_Line (File);
+ end if;
+
+ if fputc (Character'Pos (Item), File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+
+ File.Col := File.Col + 1;
+ end Put;
+
+ procedure Put (Item : in Character) is
+ begin
+ FIO.Check_Write_Status (AP (Current_Out));
+
+ if Current_Out.Line_Length /= 0
+ and then Current_Out.Col > Current_Out.Line_Length
+ then
+ New_Line (Current_Out);
+ end if;
+
+ if fputc (Character'Pos (Item), Current_Out.Stream) = EOF then
+ raise Device_Error;
+ end if;
+
+ Current_Out.Col := Current_Out.Col + 1;
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in String)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if Item'Length > 0 then
+
+ -- If we have bounded lines, then do things character by
+ -- character (this seems a rare case anyway!)
+
+ if File.Line_Length /= 0 then
+ for J in Item'Range loop
+ Put (File, Item (J));
+ end loop;
+
+ -- Otherwise we can output the entire string at once. Note that if
+ -- there are LF or FF characters in the string, we do not bother to
+ -- count them as line or page terminators.
+
+ else
+ FIO.Write_Buf (AP (File), Item'Address, Item'Length);
+ File.Col := File.Col + Item'Length;
+ end if;
+ end if;
+ end Put;
+
+ procedure Put (Item : in String) is
+ begin
+ Put (Current_Out, Item);
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line
+ (File : in File_Type;
+ Item : in String)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ -- If we have bounded lines, then just do a put and a new line. In
+ -- this case we will end up doing things character by character in
+ -- any case, and it is a rare situation.
+
+ if File.Line_Length /= 0 then
+ Put (File, Item);
+ New_Line (File);
+ return;
+ end if;
+
+ -- We setup a single string that has the necessary terminators and
+ -- then write it with a single call. The reason for doing this is
+ -- that it gives better behavior for the use of Put_Line in multi-
+ -- tasking programs, since often the OS will treat the entire put
+ -- operation as an atomic operation.
+
+ declare
+ Ilen : constant Natural := Item'Length;
+ Buffer : String (1 .. Ilen + 2);
+ Plen : size_t;
+
+ begin
+ Buffer (1 .. Ilen) := Item;
+ Buffer (Ilen + 1) := Character'Val (LM);
+
+ if File.Page_Length /= 0
+ and then File.Line > File.Page_Length
+ then
+ Buffer (Ilen + 2) := Character'Val (PM);
+ Plen := size_t (Ilen) + 2;
+ File.Line := 1;
+ File.Page := File.Page + 1;
+
+ else
+ Plen := size_t (Ilen) + 1;
+ File.Line := File.Line + 1;
+ end if;
+
+ FIO.Write_Buf (AP (File), Buffer'Address, Plen);
+
+ File.Col := 1;
+ end;
+ end Put_Line;
+
+ procedure Put_Line (Item : in String) is
+ begin
+ Put_Line (Current_Out, Item);
+ end Put_Line;
+
+ ----------
+ -- Putc --
+ ----------
+
+ procedure Putc (ch : int; File : File_Type) is
+ begin
+ if fputc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end Putc;
+
+ ----------
+ -- Read --
+ ----------
+
+ -- This is the primitive Stream Read routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Read
+ (File : in out Text_AFCB;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ ch : int;
+
+ begin
+ if File.Mode /= FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Deal with case where our logical and physical position do not match
+ -- because of being after an LM or LM-PM sequence when in fact we are
+ -- logically positioned before it.
+
+ if File.Before_LM then
+
+ -- If we are before a PM, then it is possible for a stream read
+ -- to leave us after the LM and before the PM, which is a bit
+ -- odd. The easiest way to deal with this is to unget the PM,
+ -- so we are indeed positioned between the characters. This way
+ -- further stream read operations will work correctly, and the
+ -- effect on text processing is a little weird, but what can
+ -- be expected if stream and text input are mixed this way?
+
+ if File.Before_LM_PM then
+ ch := ungetc (PM, File.Stream);
+ File.Before_LM_PM := False;
+ end if;
+
+ File.Before_LM := False;
+
+ Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
+
+ if Item'Length = 1 then
+ Last := Item'Last;
+
+ else
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (buffer => Item'Address,
+ index => size_t (Item'First + 1),
+ size => 1,
+ count => Item'Length - 1,
+ stream => File.Stream));
+ end if;
+
+ return;
+ end if;
+
+ -- Now we do the read. Since this is a text file, it is normally in
+ -- text mode, but stream data must be read in binary mode, so we
+ -- temporarily set binary mode for the read, resetting it after.
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ set_binary_mode (fileno (File.Stream));
+
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
+
+ if Last < Item'Last then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end Read;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset
+ (File : in out File_Type;
+ Mode : in File_Mode)
+ is
+ begin
+ -- Don't allow change of mode for current file (RM A.10.2(5))
+
+ if (File = Current_In or else
+ File = Current_Out or else
+ File = Current_Error)
+ and then To_FCB (Mode) /= File.Mode
+ then
+ raise Mode_Error;
+ end if;
+
+ Terminate_Line (File);
+ FIO.Reset (AP (File), To_FCB (Mode));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ procedure Reset (File : in out File_Type) is
+ begin
+ Terminate_Line (File);
+ FIO.Reset (AP (File));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ -------------
+ -- Set_Col --
+ -------------
+
+ procedure Set_Col
+ (File : in File_Type;
+ To : in Positive_Count)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Col then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Line_Length /= 0 and then To > File.Line_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Col then
+ New_Line (File);
+ end if;
+
+ while File.Col < To loop
+ Put (File, ' ');
+ end loop;
+
+ else
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+
+ elsif To = File.Col then
+ Ungetc (ch, File);
+ return;
+
+ else
+ File.Col := File.Col + 1;
+ end if;
+ end loop;
+ end if;
+ end Set_Col;
+
+ procedure Set_Col (To : in Positive_Count) is
+ begin
+ Set_Col (Current_Out, To);
+ end Set_Col;
+
+ ---------------
+ -- Set_Error --
+ ---------------
+
+ procedure Set_Error (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Err := File;
+ end Set_Error;
+
+ ---------------
+ -- Set_Input --
+ ---------------
+
+ procedure Set_Input (File : in File_Type) is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Current_In := File;
+ end Set_Input;
+
+ --------------
+ -- Set_Line --
+ --------------
+
+ procedure Set_Line
+ (File : in File_Type;
+ To : in Positive_Count)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Line then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Page_Length /= 0 and then To > File.Page_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Line then
+ New_Page (File);
+ end if;
+
+ while File.Line < To loop
+ New_Line (File);
+ end loop;
+
+ else
+ while To /= File.Line loop
+ Skip_Line (File);
+ end loop;
+ end if;
+ end Set_Line;
+
+ procedure Set_Line (To : in Positive_Count) is
+ begin
+ Set_Line (Current_Out, To);
+ end Set_Line;
+
+ ---------------------
+ -- Set_Line_Length --
+ ---------------------
+
+ procedure Set_Line_Length (File : in File_Type; To : in Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Line_Length := To;
+ end Set_Line_Length;
+
+ procedure Set_Line_Length (To : in Count) is
+ begin
+ Set_Line_Length (Current_Out, To);
+ end Set_Line_Length;
+
+ ----------------
+ -- Set_Output --
+ ----------------
+
+ procedure Set_Output (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Out := File;
+ end Set_Output;
+
+ ---------------------
+ -- Set_Page_Length --
+ ---------------------
+
+ procedure Set_Page_Length (File : in File_Type; To : in Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Page_Length := To;
+ end Set_Page_Length;
+
+ procedure Set_Page_Length (To : in Count) is
+ begin
+ Set_Page_Length (Current_Out, To);
+ end Set_Page_Length;
+
+ ---------------
+ -- Skip_Line --
+ ---------------
+
+ procedure Skip_Line
+ (File : in File_Type;
+ Spacing : in Positive_Count := 1)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Read_Status (AP (File));
+
+ for L in 1 .. Spacing loop
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ else
+ ch := Getc (File);
+
+ -- If at end of file now, then immediately raise End_Error. Note
+ -- that we can never be positioned between a line mark and a page
+ -- mark, so if we are at the end of file, we cannot logically be
+ -- before the implicit page mark that is at the end of the file.
+
+ -- For the same reason, we do not need an explicit check for a
+ -- page mark. If there is a FF in the middle of a line, the file
+ -- is not in canonical format and we do not care about the page
+ -- numbers for files other than ones in canonical format.
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+
+ -- If not at end of file, then loop till we get to an LM or EOF.
+ -- The latter case happens only in non-canonical files where the
+ -- last line is not terminated by LM, but we don't want to blow
+ -- up for such files, so we assume an implicit LM in this case.
+
+ loop
+ exit when ch = LM or ch = EOF;
+ ch := Getc (File);
+ end loop;
+ end if;
+
+ -- We have got past a line mark, now, for a regular file only,
+ -- see if a page mark immediately follows this line mark and
+ -- if so, skip past the page mark as well. We do not do this
+ -- for non-regular files, since it would cause an undesirable
+ -- wait for an additional character.
+
+ File.Col := 1;
+ File.Line := File.Line + 1;
+
+ if File.Before_LM_PM then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Before_LM_PM := False;
+
+ elsif File.Is_Regular_File then
+ ch := Getc (File);
+
+ -- Page mark can be explicit, or implied at the end of the file
+
+ if (ch = PM or else ch = EOF)
+ and then File.Is_Regular_File
+ then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+
+ end loop;
+ end Skip_Line;
+
+ procedure Skip_Line (Spacing : in Positive_Count := 1) is
+ begin
+ Skip_Line (Current_In, Spacing);
+ end Skip_Line;
+
+ ---------------
+ -- Skip_Page --
+ ---------------
+
+ procedure Skip_Page (File : in File_Type) is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If at page mark already, just skip it
+
+ if File.Before_LM_PM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ return;
+ end if;
+
+ -- This is a bit tricky, if we are logically before an LM then
+ -- it is not an error if we are at an end of file now, since we
+ -- are not really at it.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := Getc (File);
+
+ -- Otherwise we do raise End_Error if we are at the end of file now
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+ end if;
+
+ -- Now we can just rumble along to the next page mark, or to the
+ -- end of file, if that comes first. The latter case happens when
+ -- the page mark is implied at the end of file.
+
+ loop
+ exit when ch = EOF
+ or else (ch = PM and then File.Is_Regular_File);
+ ch := Getc (File);
+ end loop;
+
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ end Skip_Page;
+
+ procedure Skip_Page is
+ begin
+ Skip_Page (Current_In);
+ end Skip_Page;
+
+ --------------------
+ -- Standard_Error --
+ --------------------
+
+ function Standard_Error return File_Type is
+ begin
+ return Standard_Err;
+ end Standard_Error;
+
+ function Standard_Error return File_Access is
+ begin
+ return Standard_Err'Access;
+ end Standard_Error;
+
+ --------------------
+ -- Standard_Input --
+ --------------------
+
+ function Standard_Input return File_Type is
+ begin
+ return Standard_In;
+ end Standard_Input;
+
+ function Standard_Input return File_Access is
+ begin
+ return Standard_In'Access;
+ end Standard_Input;
+
+ ---------------------
+ -- Standard_Output --
+ ---------------------
+
+ function Standard_Output return File_Type is
+ begin
+ return Standard_Out;
+ end Standard_Output;
+
+ function Standard_Output return File_Access is
+ begin
+ return Standard_Out'Access;
+ end Standard_Output;
+
+ --------------------
+ -- Terminate_Line --
+ --------------------
+
+ procedure Terminate_Line (File : File_Type) is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ -- For file other than In_File, test for needing to terminate last line
+
+ if Mode (File) /= In_File then
+
+ -- If not at start of line definition need new line
+
+ if File.Col /= 1 then
+ New_Line (File);
+
+ -- For files other than standard error and standard output, we
+ -- make sure that an empty file has a single line feed, so that
+ -- it is properly formatted. We avoid this for the standard files
+ -- because it is too much of a nuisance to have these odd line
+ -- feeds when nothing has been written to the file.
+
+ elsif (File /= Standard_Err and then File /= Standard_Out)
+ and then (File.Line = 1 and then File.Page = 1)
+ then
+ New_Line (File);
+ end if;
+ end if;
+ end Terminate_Line;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+ -----------
+ -- Write --
+ -----------
+
+ -- This is the primitive Stream Write routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Write
+ (File : in out Text_AFCB;
+ Item : in Stream_Element_Array)
+ is
+
+ function Has_Translated_Characters return Boolean;
+ -- return True if Item array contains a character which will be
+ -- translated under the text file mode. There is only one such
+ -- character under DOS based systems which is character 10.
+
+ text_translation_required : Boolean;
+ pragma Import (C, text_translation_required,
+ "__gnat_text_translation_required");
+
+ Siz : constant size_t := Item'Length;
+
+ function Has_Translated_Characters return Boolean is
+ begin
+ for K in Item'Range loop
+ if Item (K) = 10 then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Has_Translated_Characters;
+
+ Needs_Binary_Write : constant Boolean :=
+ text_translation_required and then Has_Translated_Characters;
+
+ begin
+ if File.Mode = FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Now we do the write. Since this is a text file, it is normally in
+ -- text mode, but stream data must be written in binary mode, so we
+ -- temporarily set binary mode for the write, resetting it after. This
+ -- is done only if needed (i.e. there is some characters in Item which
+ -- needs to be written using the binary mode).
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ -- Since the character translation is done at the time the buffer is
+ -- written (this is true under Windows) we first flush current buffer
+ -- with text mode if needed.
+
+ if Needs_Binary_Write then
+
+ if fflush (File.Stream) = -1 then
+ raise Device_Error;
+ end if;
+
+ set_binary_mode (fileno (File.Stream));
+ end if;
+
+ if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
+ raise Device_Error;
+ end if;
+
+ -- At this point we need to flush the buffer using the binary mode then
+ -- we reset to text mode.
+
+ if Needs_Binary_Write then
+
+ if fflush (File.Stream) = -1 then
+ raise Device_Error;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end if;
+ end Write;
+
+ -- Use "preallocated" strings to avoid calling "new" during the
+ -- elaboration of the run time. This is needed in the tasking case to
+ -- avoid calling Task_Lock too early. A filename is expected to end with a
+ -- null character in the runtime, here the null characters are added just
+ -- to have a correct filename length.
+
+ Err_Name : aliased String := "*stderr" & ASCII.Nul;
+ In_Name : aliased String := "*stdin" & ASCII.Nul;
+ Out_Name : aliased String := "*stdout" & ASCII.Nul;
+begin
+ -------------------------------
+ -- Initialize Standard Files --
+ -------------------------------
+
+ -- Note: the names in these files are bogus, and probably it would be
+ -- better for these files to have no names, but the ACVC test insist!
+ -- We use names that are bound to fail in open etc.
+
+ Standard_Err.Stream := stderr;
+ Standard_Err.Name := Err_Name'Access;
+ Standard_Err.Form := Null_Str'Unrestricted_Access;
+ Standard_Err.Mode := FCB.Out_File;
+ Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
+ Standard_Err.Is_Temporary_File := False;
+ Standard_Err.Is_System_File := True;
+ Standard_Err.Is_Text_File := True;
+ Standard_Err.Access_Method := 'T';
+ Standard_Err.Self := Standard_Err;
+
+ Standard_In.Stream := stdin;
+ Standard_In.Name := In_Name'Access;
+ Standard_In.Form := Null_Str'Unrestricted_Access;
+ Standard_In.Mode := FCB.In_File;
+ Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
+ Standard_In.Is_Temporary_File := False;
+ Standard_In.Is_System_File := True;
+ Standard_In.Is_Text_File := True;
+ Standard_In.Access_Method := 'T';
+ Standard_In.Self := Standard_In;
+
+ Standard_Out.Stream := stdout;
+ Standard_Out.Name := Out_Name'Access;
+ Standard_Out.Form := Null_Str'Unrestricted_Access;
+ Standard_Out.Mode := FCB.Out_File;
+ Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
+ Standard_Out.Is_Temporary_File := False;
+ Standard_Out.Is_System_File := True;
+ Standard_Out.Is_Text_File := True;
+ Standard_Out.Access_Method := 'T';
+ Standard_Out.Self := Standard_Out;
+
+ FIO.Chain_File (AP (Standard_In));
+ FIO.Chain_File (AP (Standard_Out));
+ FIO.Chain_File (AP (Standard_Err));
+
+ FIO.Make_Unbuffered (AP (Standard_Out));
+ FIO.Make_Unbuffered (AP (Standard_Err));
+
+end Ada.Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.51 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: the generic subpackages of Text_IO (Integer_IO, Float_IO, Fixed_IO,
+-- Modular_IO, Decimal_IO and Enumeration_IO) appear as private children in
+-- GNAT. These children are with'ed automatically if they are referenced, so
+-- this rearrangement is invisible to user programs, but has the advantage
+-- that only the needed parts of Text_IO are processed and loaded.
+
+with Ada.IO_Exceptions;
+with Ada.Streams;
+with System;
+with System.File_Control_Block;
+
+package Ada.Text_IO is
+pragma Elaborate_Body (Text_IO);
+
+ 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)
+
+ type Count is range 0 .. Natural'Last;
+ -- The value of Count'Last must be large enough so that the assumption
+ -- enough so that the assumption that the Line, Column and Page
+ -- counts can never exceed this value is a valid assumption.
+
+ subtype Positive_Count is Count range 1 .. Count'Last;
+
+ Unbounded : constant Count := 0;
+ -- Line and page length
+
+ subtype Field is Integer range 0 .. 255;
+ -- Note: if for any reason, there is a need to increase this value,
+ -- then it will be necessary to change the corresponding value in
+ -- System.Img_Real in file s-imgrea.adb.
+
+ subtype Number_Base is Integer range 2 .. 16;
+
+ type Type_Set is (Lower_Case, Upper_Case);
+
+ ---------------------
+ -- 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;
+
+ ------------------------------------------------------
+ -- Control of default input, output and error files --
+ ------------------------------------------------------
+
+ procedure Set_Input (File : in File_Type);
+ procedure Set_Output (File : in File_Type);
+ procedure Set_Error (File : in File_Type);
+
+ function Standard_Input return File_Type;
+ function Standard_Output return File_Type;
+ function Standard_Error return File_Type;
+
+ function Current_Input return File_Type;
+ function Current_Output return File_Type;
+ function Current_Error return File_Type;
+
+ type File_Access is access constant File_Type;
+
+ function Standard_Input return File_Access;
+ function Standard_Output return File_Access;
+ function Standard_Error return File_Access;
+
+ function Current_Input return File_Access;
+ function Current_Output return File_Access;
+ function Current_Error return File_Access;
+
+ --------------------
+ -- Buffer control --
+ --------------------
+
+ -- Note: The parameter file is IN OUT in the RM, but this is clearly
+ -- an oversight, and was intended to be IN, see AI95-00057.
+
+ procedure Flush (File : in File_Type);
+ procedure Flush;
+
+ --------------------------------------------
+ -- Specification of line and page lengths --
+ --------------------------------------------
+
+ procedure Set_Line_Length (File : in File_Type; To : in Count);
+ procedure Set_Line_Length (To : in Count);
+
+ procedure Set_Page_Length (File : in File_Type; To : in Count);
+ procedure Set_Page_Length (To : in Count);
+
+ function Line_Length (File : in File_Type) return Count;
+ function Line_Length return Count;
+
+ function Page_Length (File : in File_Type) return Count;
+ function Page_Length return Count;
+
+ ------------------------------------
+ -- Column, Line, and Page Control --
+ ------------------------------------
+
+ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1);
+ procedure New_Line (Spacing : in Positive_Count := 1);
+
+ procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1);
+ procedure Skip_Line (Spacing : in Positive_Count := 1);
+
+ function End_Of_Line (File : in File_Type) return Boolean;
+ function End_Of_Line return Boolean;
+
+ procedure New_Page (File : in File_Type);
+ procedure New_Page;
+
+ procedure Skip_Page (File : in File_Type);
+ procedure Skip_Page;
+
+ function End_Of_Page (File : in File_Type) return Boolean;
+ function End_Of_Page return Boolean;
+
+ function End_Of_File (File : in File_Type) return Boolean;
+ function End_Of_File return Boolean;
+
+ procedure Set_Col (File : in File_Type; To : in Positive_Count);
+ procedure Set_Col (To : in Positive_Count);
+
+ procedure Set_Line (File : in File_Type; To : in Positive_Count);
+ procedure Set_Line (To : in Positive_Count);
+
+ function Col (File : in File_Type) return Positive_Count;
+ function Col return Positive_Count;
+
+ function Line (File : in File_Type) return Positive_Count;
+ function Line return Positive_Count;
+
+ function Page (File : in File_Type) return Positive_Count;
+ function Page return Positive_Count;
+
+ ----------------------------
+ -- Character Input-Output --
+ ----------------------------
+
+ procedure Get (File : in File_Type; Item : out Character);
+ procedure Get (Item : out Character);
+ procedure Put (File : in File_Type; Item : in Character);
+ procedure Put (Item : in Character);
+
+ procedure Look_Ahead
+ (File : in File_Type;
+ Item : out Character;
+ End_Of_Line : out Boolean);
+
+ procedure Look_Ahead
+ (Item : out Character;
+ End_Of_Line : out Boolean);
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Character);
+
+ procedure Get_Immediate
+ (Item : out Character);
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Character;
+ Available : out Boolean);
+
+ procedure Get_Immediate
+ (Item : out Character;
+ Available : out Boolean);
+
+ -------------------------
+ -- String Input-Output --
+ -------------------------
+
+ procedure Get (File : in File_Type; Item : out String);
+ procedure Get (Item : out String);
+ procedure Put (File : in File_Type; Item : in String);
+ procedure Put (Item : in String);
+
+ procedure Get_Line
+ (File : in File_Type;
+ Item : out String;
+ Last : out Natural);
+
+ procedure Get_Line
+ (Item : out String;
+ Last : out Natural);
+
+ procedure Put_Line
+ (File : in File_Type;
+ Item : in String);
+
+ procedure Put_Line
+ (Item : in String);
+
+ ---------------------------------------
+ -- Generic packages for Input-Output --
+ ---------------------------------------
+
+ -- The generic packages:
+
+ -- Ada.Text_IO.Integer_IO
+ -- Ada.Text_IO.Modular_IO
+ -- Ada.Text_IO.Float_IO
+ -- Ada.Text_IO.Fixed_IO
+ -- Ada.Text_IO.Decimal_IO
+ -- Ada.Text_IO.Enumeration_IO
+
+ -- are implemented as separate child packages in GNAT, so the
+ -- spec and body of these packages are to be found in separate
+ -- child units. This implementation detail is hidden from the
+ -- Ada programmer by special circuitry in the compiler that
+ -- treats these child packages as though they were nested in
+ -- Text_IO. The advantage of this special processing is that
+ -- the subsidiary routines needed if these generics are used
+ -- are not loaded when they are not used.
+
+ ----------------
+ -- 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;
+ Layout_Error : exception renames IO_Exceptions.Layout_Error;
+
+private
+ -----------------------------------
+ -- Handling of Format Characters --
+ -----------------------------------
+
+ -- Line marks are represented by the single character ASCII.LF (16#0A#).
+ -- In DOS and similar systems, underlying file translation takes care
+ -- of translating this to and from the standard CR/LF sequences used in
+ -- these operating systems to mark the end of a line. On output there is
+ -- always a line mark at the end of the last line, but on input, this
+ -- line mark can be omitted, and is implied by the end of file.
+
+ -- Page marks are represented by the single character ASCII.FF (16#0C#),
+ -- The page mark at the end of the file may be omitted, and is normally
+ -- omitted on output unless an explicit New_Page call is made before
+ -- closing the file. No page mark is added when a file is appended to,
+ -- so, in accordance with the permission in (RM A.10.2(4)), there may
+ -- or may not be a page mark separating preexising text in the file
+ -- from the new text to be written.
+
+ -- A file mark is marked by the physical end of file. In DOS translation
+ -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the
+ -- physical end of file, so in effect this character is recognized as
+ -- marking the end of file in DOS and similar systems.
+
+ LM : constant := Character'Pos (ASCII.LF);
+ -- Used as line mark
+
+ PM : constant := Character'Pos (ASCII.FF);
+ -- Used as page mark, except at end of file where it is implied
+
+ --------------------------------
+ -- Text_IO File Control Block --
+ --------------------------------
+
+ package FCB renames System.File_Control_Block;
+
+ type Text_AFCB;
+ type File_Type is access all Text_AFCB;
+
+ type Text_AFCB is new FCB.AFCB with record
+ Page : Count := 1;
+ Line : Count := 1;
+ Col : Count := 1;
+ Line_Length : Count := 0;
+ Page_Length : Count := 0;
+
+ Self : aliased File_Type;
+ -- Set to point to the containing Text_AFCB block. This is used to
+ -- implement the Current_{Error,Input,Ouput} functions which return
+ -- a File_Access, the file access value returned is a pointer to
+ -- the Self field of the corresponding file.
+
+ Before_LM : Boolean := False;
+ -- This flag is used to deal with the anomolies introduced by the
+ -- peculiar definition of End_Of_File and End_Of_Page in Ada. These
+ -- functions require looking ahead more than one character. Since
+ -- there is no convenient way of backing up more than one character,
+ -- what we do is to leave ourselves positioned past the LM, but set
+ -- this flag, so that we know that from an Ada point of view we are
+ -- in front of the LM, not after it. A bit of a kludge, but it works!
+
+ Before_LM_PM : Boolean := False;
+ -- This flag similarly handles the case of being physically positioned
+ -- after a LM-PM sequence when logically we are before the LM-PM. This
+ -- flag can only be set if Before_LM is also set.
+
+ end record;
+
+ function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr;
+
+ procedure AFCB_Close (File : access Text_AFCB);
+ procedure AFCB_Free (File : access Text_AFCB);
+
+ procedure Read
+ (File : in out Text_AFCB;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset);
+ -- Read operation used when Text_IO file is treated directly as Stream
+
+ procedure Write
+ (File : in out Text_AFCB;
+ Item : in Ada.Streams.Stream_Element_Array);
+ -- Write operation used when Text_IO file is treated directly as Stream
+
+ ------------------------
+ -- The Standard Files --
+ ------------------------
+
+ Null_Str : aliased constant String := "";
+ -- Used as name and form of standard files
+
+ Standard_Err_AFCB : aliased Text_AFCB;
+ Standard_In_AFCB : aliased Text_AFCB;
+ Standard_Out_AFCB : aliased Text_AFCB;
+
+ Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
+ Standard_In : aliased File_Type := Standard_In_AFCB'Access;
+ Standard_Out : aliased File_Type := Standard_Out_AFCB'Access;
+ -- Standard files
+
+ Current_In : aliased File_Type := Standard_In;
+ Current_Out : aliased File_Type := Standard_Out;
+ Current_Err : aliased File_Type := Standard_Err;
+ -- Current files
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- These subprograms are in the private part of the spec so that they can
+ -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO.
+
+ -- Note: we use Integer in these declarations instead of the more accurate
+ -- Interfaces.C_Streams.int, because we do not want to drag in the spec of
+ -- this interfaces package with the spec of Ada.Text_IO, and we know that
+ -- in fact these types are identical
+
+ function Getc (File : File_Type) return Integer;
+ -- Gets next character from file, which has already been checked for
+ -- being in read status, and returns the character read if no error
+ -- occurs. The result is EOF if the end of file was read.
+
+ function Nextc (File : File_Type) return Integer;
+ -- Returns next character from file without skipping past it (i.e. it
+ -- is a combination of Getc followed by an Ungetc).
+
+ procedure Putc (ch : Integer; File : File_Type);
+ -- Outputs the given character to the file, which has already been
+ -- checked for being in output status. Device_Error is raised if the
+ -- character cannot be written.
+
+ procedure Terminate_Line (File : File_Type);
+ -- If the file is in Write_File or Append_File mode, and the current
+ -- line is not terminated, then a line terminator is written using
+ -- New_Line. Note that there is no Terminate_Page routine, because
+ -- the page mark at the end of the file is implied if necessary.
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- and end of file character (EOF) is ignored.
+
+end Ada.Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+with Ada.Text_IO.Float_Aux;
+
+with System.Img_Real; use System.Img_Real;
+
+package body Ada.Text_IO.Complex_Aux is
+
+ package Aux renames Ada.Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer;
+ Paren : Boolean := False;
+
+ begin
+ -- General note for following code, exceptions from the calls to
+ -- Get for components of the complex value are propagated.
+
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr);
+
+ for J in Ptr + 1 .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+
+ -- Case of width = 0
+
+ else
+ Load_Skip (File);
+ Ptr := 0;
+ Load (File, Buf, Ptr, '(', Paren);
+ Aux.Get (File, ItemR, 0);
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ',');
+ Aux.Get (File, ItemI, 0);
+
+ if Paren then
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ')', Paren);
+
+ if not Paren then
+ raise Data_Error;
+ end if;
+ end if;
+ end if;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : in String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Paren : Boolean;
+ Pos : Integer;
+
+ begin
+ String_Skip (From, Pos);
+
+ if From (Pos) = '(' then
+ Pos := Pos + 1;
+ Paren := True;
+ else
+ Paren := False;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemR, Pos);
+
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) = ',' then
+ Pos := Pos + 1;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemI, Pos);
+
+ if Paren then
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) /= ')' then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Last := Pos;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field)
+ is
+ begin
+ Put (File, '(');
+ Aux.Put (File, ItemR, Fore, Aft, Exp);
+ Put (File, ',');
+ Aux.Put (File, ItemI, Fore, Aft, Exp);
+ Put (File, ')');
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ I_String : String (1 .. 3 * Field'Last);
+ R_String : String (1 .. 3 * Field'Last);
+
+ Iptr : Natural;
+ Rptr : Natural;
+
+ begin
+ -- Both parts are initially converted with a Fore of 0
+
+ Rptr := 0;
+ Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Iptr := 0;
+ Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+
+ -- Check room for both parts plus parens plus comma (RM G.1.3(34))
+
+ if Rptr + Iptr + 3 > To'Length then
+ raise Layout_Error;
+ end if;
+
+ -- If there is room, layout result according to (RM G.1.3(31-33))
+
+ To (To'First) := '(';
+ To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr);
+ To (To'First + Rptr + 1) := ',';
+
+ To (To'Last) := ')';
+ To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr);
+
+ for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop
+ To (J) := ' ';
+ end loop;
+
+ end Puts;
+
+end Ada.Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- 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 contains the routines for Ada.Text_IO.Complex_IO that are
+-- shared among separate instantiations of this package. The routines in
+-- this package are identical semantically to those in Complex_IO itself,
+-- except that the generic parameter Complex has been replaced by separate
+-- real and imaginary values of type Long_Long_Float, and default parameters
+-- have been removed because they are supplied explicitly by the calls from
+-- within the generic template.
+
+package Ada.Text_IO.Complex_Aux is
+
+ procedure Get
+ (File : in File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field);
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field);
+
+ procedure Gets
+ (From : String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : Field;
+ Exp : Field);
+
+end Ada.Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . C O M P L E X _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Text_IO;
+
+with Ada.Text_IO.Complex_Aux;
+
+package body Ada.Text_IO.Complex_IO is
+
+ package Aux renames Ada.Text_IO.Complex_Aux;
+
+ subtype LLF is Long_Long_Float;
+ -- Type used for calls to routines in Aux
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Complex_Types.Complex;
+ Width : in Field := 0)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ begin
+ Aux.Get (File, LLF (Real_Item), LLF (Imag_Item), Width);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (Item : out Complex_Types.Complex;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (From : in String;
+ Item : out Complex_Types.Complex;
+ Last : out Positive)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ begin
+ Aux.Gets (From, LLF (Real_Item), LLF (Imag_Item), Last);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Data_Error => raise Constraint_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Complex_Types.Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (File, LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (Item : in Complex_Types.Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (To : out String;
+ Item : in Complex_Types.Complex;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Puts (To, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+ end Put;
+
+end Ada.Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . C O M P L E X _ I O --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Numerics.Generic_Complex_Types;
+
+generic
+ with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>);
+
+package Ada.Text_IO.Complex_IO is
+
+ use Complex_Types;
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Real'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Complex;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Complex;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in String;
+ Item : out Complex;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Complex;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- 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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux;
+
+with System.Img_Dec; use System.Img_Dec;
+with System.Img_LLD; use System.Img_LLD;
+with System.Val_Dec; use System.Val_Dec;
+with System.Val_LLD; use System.Val_LLD;
+
+package body Ada.Text_IO.Decimal_Aux is
+
+ -------------
+ -- Get_Dec --
+ -------------
+
+ function Get_Dec
+ (File : in File_Type;
+ Width : in Field;
+ Scale : Integer)
+ return Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_Dec;
+
+ -------------
+ -- Get_LLD --
+ -------------
+
+ function Get_LLD
+ (File : in File_Type;
+ Width : in Field;
+ Scale : Integer)
+ return Long_Long_Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Long_Long_Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_LLD;
+
+ --------------
+ -- Gets_Dec --
+ --------------
+
+ function Gets_Dec
+ (From : in String;
+ Last : access Positive;
+ Scale : Integer)
+ return Integer
+ is
+ Pos : aliased Integer;
+ Item : Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+ end Gets_Dec;
+
+ --------------
+ -- Gets_LLD --
+ --------------
+
+ function Gets_LLD
+ (From : in String;
+ Last : access Positive;
+ Scale : Integer)
+ return Long_Long_Integer
+ is
+ Pos : aliased Integer;
+ Item : Long_Long_Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+ end Gets_LLD;
+
+ -------------
+ -- Put_Dec --
+ -------------
+
+ procedure Put_Dec
+ (File : in File_Type;
+ Item : in Integer;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Dec;
+
+ -------------
+ -- Put_LLD --
+ -------------
+
+ procedure Put_LLD
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLD;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : in Integer;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_Dec;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLD;
+
+end Ada.Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Text_IO.Decimal_IO that are
+-- shared among separate instantiations of this package. The routines in
+-- the package are identical semantically to those declared in Text_IO,
+-- except that default values have been supplied by the generic, and the
+-- Num parameter has been replaced by Integer or Long_Long_Integer, with
+-- an additional Scale parameter giving the value of Num'Scale. In addition
+-- the Get routines return the value rather than store it in an Out parameter.
+
+private package Ada.Text_IO.Decimal_Aux is
+
+ function Get_Dec
+ (File : in File_Type;
+ Width : in Field;
+ Scale : Integer)
+ return Integer;
+
+ function Get_LLD
+ (File : in File_Type;
+ Width : in Field;
+ Scale : Integer)
+ return Long_Long_Integer;
+
+ procedure Put_Dec
+ (File : File_Type;
+ Item : Integer;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer);
+
+ procedure Put_LLD
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer);
+
+ function Gets_Dec
+ (From : in String;
+ Last : access Positive;
+ Scale : Integer)
+ return Integer;
+
+ function Gets_LLD
+ (From : in String;
+ Last : access Positive;
+ Scale : Integer)
+ return Long_Long_Integer;
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : in Integer;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer);
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Aft : in Field;
+ Exp : in Field;
+ Scale : Integer);
+
+end Ada.Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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.Text_IO.Decimal_Aux;
+
+package body Ada.Text_IO.Decimal_IO is
+
+ package Aux renames Ada.Text_IO.Decimal_Aux;
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Num'Size > Integer'Size then
+ Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale));
+
+ else
+ Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_In, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Num'Size > Integer'Size then
+ Item := Num'Fixed_Value
+ (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale));
+ else
+ Item := Num'Fixed_Value
+ (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Aux.Put_LLD
+ (File, Long_Long_Integer'Integer_Value (Item),
+ Fore, Aft, Exp, Scale);
+ else
+ Aux.Put_Dec
+ (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Out, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Aux.Puts_LLD
+ (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
+ else
+ Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Decimal_IO is a subpackage of Text_IO.
+-- This is for compatibility with Ada 83. In GNAT we make it a child package
+-- to avoid loading the necessary code if Decimal_IO is not instantiated. See
+-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <> digits <>;
+
+package Ada.Text_IO.Decimal_IO is
+
+ Default_Fore : Field := Num'Fore;
+ Default_Aft : Field := Num'Aft;
+ Default_Exp : Field := 0;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+
+-- Note: this package does not yet deal properly with wide characters ???
+
+package body Ada.Text_IO.Enumeration_Aux is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- These definitions replace the ones in Ada.Characters.Handling, which
+ -- do not seem to work for some strange not understood reason ??? at
+ -- least in the OS/2 version.
+
+ function To_Lower (C : Character) return Character;
+ function To_Upper (C : Character) return Character;
+
+ ------------------
+ -- Get_Enum_Lit --
+ ------------------
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out String;
+ Buflen : out Natural)
+ is
+ ch : int;
+ C : Character;
+
+ begin
+ Buflen := 0;
+ Load_Skip (File);
+ ch := Getc (File);
+ C := Character'Val (ch);
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L)
+
+ if C = ''' then
+ Store_Char (File, ch, Buf, Buflen);
+
+ ch := Getc (File);
+
+ if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
+ Store_Char (File, ch, Buf, Buflen);
+
+ ch := Getc (File);
+
+ if ch = Character'Pos (''') then
+ Store_Char (File, ch, Buf, Buflen);
+ else
+ Ungetc (ch, File);
+ end if;
+
+ else
+ Ungetc (ch, File);
+ end if;
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter
+
+ if not Is_Letter (C) then
+ Ungetc (ch, File);
+ return;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ loop
+ C := Character'Val (ch);
+ Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
+
+ ch := Getc (File);
+ exit when ch = EOF;
+ C := Character'Val (ch);
+
+ exit when not Is_Letter (C)
+ and then not Is_Digit (C)
+ and then C /= '_';
+
+ exit when C = '_'
+ and then Buf (Buflen) = '_';
+ end loop;
+
+ Ungetc (ch, File);
+ end if;
+ end Get_Enum_Lit;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : String;
+ Width : Field;
+ Set : Type_Set)
+ is
+ Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
+
+ begin
+ if Set = Lower_Case and then Item (1) /= ''' then
+ declare
+ Iteml : String (Item'First .. Item'Last);
+
+ begin
+ for J in Item'Range loop
+ Iteml (J) := To_Lower (Item (J));
+ end loop;
+
+ Put_Item (File, Iteml);
+ end;
+
+ else
+ Put_Item (File, Item);
+ end if;
+
+ for J in 1 .. Actual_Width - Item'Length loop
+ Put (File, ' ');
+ end loop;
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : in String;
+ Set : Type_Set)
+ is
+ Ptr : Natural;
+
+ begin
+ if Item'Length > To'Length then
+ raise Layout_Error;
+
+ else
+ Ptr := To'First;
+ for J in Item'Range loop
+ if Set = Lower_Case and then Item (1) /= ''' then
+ To (Ptr) := To_Lower (Item (J));
+ else
+ To (Ptr) := Item (J);
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ while Ptr <= To'Last loop
+ To (Ptr) := ' ';
+ Ptr := Ptr + 1;
+ end loop;
+ end if;
+ end Puts;
+
+ -------------------
+ -- Scan_Enum_Lit --
+ -------------------
+
+ procedure Scan_Enum_Lit
+ (From : String;
+ Start : out Natural;
+ Stop : out Natural)
+ is
+ C : Character;
+
+ -- Processing for Scan_Enum_Lit
+
+ begin
+ String_Skip (From, Start);
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L
+ -- which is for the analogous case for reading from a file).
+
+ if From (Start) = ''' then
+ Stop := Start;
+
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+ end if;
+
+ if From (Stop) in ' ' .. '~'
+ or else From (Stop) >= Character'Val (16#80#)
+ then
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+
+ if From (Stop) = ''' then
+ return;
+ end if;
+ end if;
+ end if;
+
+ Stop := Stop - 1;
+ raise Data_Error;
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter
+
+ if not Is_Letter (From (Start)) then
+ raise Data_Error;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ Stop := Start;
+ while Stop < From'Last loop
+ C := From (Stop + 1);
+
+ exit when not Is_Letter (C)
+ and then not Is_Digit (C)
+ and then C /= '_';
+
+ exit when C = '_'
+ and then From (Stop) = '_';
+
+ Stop := Stop + 1;
+ end loop;
+ end if;
+
+ end Scan_Enum_Lit;
+
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ function To_Upper (C : Character) return Character is
+ begin
+ if C in 'a' .. 'z' then
+ return Character'Val (Character'Pos (C) - 32);
+ else
+ return C;
+ end if;
+ end To_Upper;
+
+end Ada.Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Text_IO.Enumeration_IO
+-- that are shared among separate instantiations of this package.
+
+private package Ada.Text_IO.Enumeration_Aux is
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out String;
+ Buflen : out Natural);
+ -- Reads an enumeration literal value from the file, folds to upper case,
+ -- and stores the result in Buf, setting Buflen to the number of stored
+ -- characters (Buf has a lower bound of 1). If more than Buflen characters
+ -- are present in the literal, Data_Error is raised.
+
+ procedure Scan_Enum_Lit
+ (From : String;
+ Start : out Natural;
+ Stop : out Natural);
+ -- Scans an enumeration literal at the start of From, skipping any leading
+ -- spaces. Sets Start to the first character, Stop to the last character.
+ -- Raises End_Error if no enumeration literal is found.
+
+ procedure Put
+ (File : File_Type;
+ Item : String;
+ Width : Field;
+ Set : Type_Set);
+ -- Outputs the enumeration literal image stored in Item to the given File,
+ -- using the given Width and Set parameters (Item is always in upper case).
+
+ procedure Puts
+ (To : out String;
+ Item : in String;
+ Set : Type_Set);
+ -- Stores the enumeration literal image stored in Item to the string To,
+ -- padding with trailing spaces if necessary to fill To. Set is used to
+
+end Ada.Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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.Text_IO.Enumeration_Aux;
+
+package body Ada.Text_IO.Enumeration_IO is
+
+ package Aux renames Ada.Text_IO.Enumeration_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (File : in File_Type; Item : out Enum) is
+ Buf : String (1 .. Enum'Width);
+ Buflen : Natural;
+
+ begin
+ Aux.Get_Enum_Lit (File, Buf, Buflen);
+
+ declare
+ Buf_Str : String renames Buf (1 .. Buflen);
+ pragma Unsuppress (Range_Check);
+ begin
+ Item := Enum'Value (Buf_Str);
+ end;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get (Item : out Enum) is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Enum;
+ Last : out Positive)
+ is
+ Start : Natural;
+
+ begin
+ Aux.Scan_Enum_Lit (From, Start, Last);
+
+ declare
+ From_Str : String renames From (Start .. Last);
+ pragma Unsuppress (Range_Check);
+ begin
+ Item := Enum'Value (From_Str);
+ end;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ Image : constant String := Enum'Image (Item);
+
+ begin
+ Aux.Put (File, Image, Width, Set);
+ end Put;
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ begin
+ Put (Current_Out, Item, Width, Set);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Enum;
+ Set : in Type_Set := Default_Setting)
+ is
+ Image : constant String := Enum'Image (Item);
+
+ begin
+ Aux.Puts (To, Image, Set);
+ end Put;
+
+end Ada.Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Enumeration_IO is a subpackage of
+-- Text_IO. This is for compatibility with Ada 83. In GNAT we make it a
+-- child package to avoid loading the necessary code if Enumeration_IO is
+-- not instantiated. See routine Rtsfind.Text_IO_Kludge for a description
+-- of how we patch up the difference in semantics so that it is invisible
+-- to the Ada programmer.
+
+private generic
+ type Enum is (<>);
+
+package Ada.Text_IO.Enumeration_IO is
+
+ Default_Width : Field := 0;
+ Default_Setting : Type_Set := Upper_Case;
+
+ procedure Get (File : in File_Type; Item : out Enum);
+ procedure Get (Item : out Enum);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+ procedure Get
+ (From : in String;
+ Item : out Enum;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Enum;
+ Set : in Type_Set := Default_Setting);
+
+end Ada.Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Text_IO.Float_Aux;
+
+package body Ada.Text_IO.Fixed_IO is
+
+ -- Note: we use the floating-point I/O routines for input/output of
+ -- ordinary fixed-point. This works fine for fixed-point declarations
+ -- whose mantissa is no longer than the mantissa of Long_Long_Float,
+ -- and we simply consider that we have only partial support for fixed-
+ -- point types with larger mantissas (this situation will not arise on
+ -- the x86, but it will rise on machines only supporting IEEE long).
+
+ package Aux renames Ada.Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Get (File, Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Get (Current_In, Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Gets (From, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ end Put;
+
+end Ada.Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F I X E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Fixed_IO is a subpackage of Text_IO.
+-- This is for compatibility with Ada 83. In GNAT we make it a child package
+-- to avoid loading the necessary code if Fixed_IO is not instantiated. See
+-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <>;
+
+package Ada.Text_IO.Fixed_IO is
+
+ Default_Fore : Field := Num'Fore;
+ Default_Aft : Field := Num'Aft;
+ Default_Exp : Field := 0;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F L O A T _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.16 $ --
+-- --
+-- 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+
+with System.Img_Real; use System.Img_Real;
+with System.Val_Real; use System.Val_Real;
+
+package body Ada.Text_IO.Float_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Long_Long_Float;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Real (Buf, Ptr'Access, Stop);
+
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : in String;
+ Item : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Real (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks, and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Based cases
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Long_Long_Float;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ Buf : String (1 .. 3 * Field'Last + 2);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : in Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ Buf : String (1 .. 3 * Field'Last + 2);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+
+ else
+ for J in 1 .. Ptr loop
+ To (To'Last - Ptr + J) := Buf (J);
+ end loop;
+
+ for J in To'First .. To'Last - Ptr loop
+ To (J) := ' ';
+ end loop;
+ end if;
+ end Puts;
+
+end Ada.Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F L O A T _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Text_IO.Float_IO that are
+-- shared among separate instantiations of this package. The routines in
+-- this package are identical semantically to those in Float_IO itself,
+-- except that generic parameter Num has been replaced by Long_Long_Float,
+-- and the default parameters have been removed because they are supplied
+-- explicitly by the calls from within the generic template. This package
+-- is also used by Ada.Text_IO.Fixed_IO, and Ada.Text_IO.Decimal_IO.
+
+private package Ada.Text_IO.Float_Aux is
+
+ procedure Load_Real
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load a possibly signed
+ -- real literal value from the input file into Buf, starting at Ptr + 1.
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Long_Long_Float;
+ Width : in Field);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Long_Long_Float;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field);
+
+ procedure Gets
+ (From : in String;
+ Item : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Puts
+ (To : out String;
+ Item : in Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field);
+
+end Ada.Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F L O A T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- 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.Text_IO.Float_Aux;
+
+package body Ada.Text_IO.Float_IO is
+
+ package Aux renames Ada.Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Get (File, Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Get (Current_In, Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ Aux.Gets (From, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ end Put;
+
+end Ada.Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . F L O A T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Float_IO is a subpackage of Text_IO.
+-- This is for compatibility with Ada 83. In GNAT we make it a child package
+-- to avoid loading the necessary code if Float_IO is not instantiated. See
+-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is digits <>;
+
+package Ada.Text_IO.Float_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.17 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.File_IO;
+with System.File_Control_Block;
+
+package body Ada.Text_IO.Generic_Aux is
+
+ package FIO renames System.File_IO;
+ package FCB renames System.File_Control_Block;
+ subtype AP is FCB.AFCB_Ptr;
+
+ ------------------------
+ -- Check_End_Of_Field --
+ ------------------------
+
+ procedure Check_End_Of_Field
+ (File : File_Type;
+ Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field)
+ is
+ begin
+ if Ptr > Stop then
+ return;
+
+ elsif Width = 0 then
+ raise Data_Error;
+
+ else
+ for J in Ptr .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+ end if;
+ end Check_End_Of_Field;
+
+ -----------------------
+ -- Check_On_One_Line --
+ -----------------------
+
+ procedure Check_On_One_Line
+ (File : File_Type;
+ Length : Integer)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Line_Length /= 0 then
+ if Count (Length) > File.Line_Length then
+ raise Layout_Error;
+ elsif File.Col + Count (Length) > File.Line_Length + 1 then
+ New_Line (File);
+ end if;
+ end if;
+ end Check_On_One_Line;
+
+ ----------
+ -- Getc --
+ ----------
+
+ function Getc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF and then ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ else
+ return ch;
+ end if;
+ end Getc;
+
+ --------------
+ -- Is_Blank --
+ --------------
+
+ function Is_Blank (C : Character) return Boolean is
+ begin
+ return C = ' ' or else C = ASCII.HT;
+ end Is_Blank;
+
+ ----------
+ -- Load --
+ ----------
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character)
+ is
+ ch : int;
+
+ begin
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character)
+ is
+ ch : int;
+
+ begin
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end Load;
+
+ -----------------
+ -- Load_Digits --
+ -----------------
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ ch := Getc (File);
+
+ if ch not in Character'Pos ('0') .. Character'Pos ('9') then
+ Loaded := False;
+
+ else
+ Loaded := True;
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end Load_Digits;
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end Load_Digits;
+
+ --------------------------
+ -- Load_Extended_Digits --
+ --------------------------
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean := False;
+
+ begin
+ Loaded := False;
+
+ loop
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9')
+ or else
+ ch in Character'Pos ('a') .. Character'Pos ('f')
+ or else
+ ch in Character'Pos ('A') .. Character'Pos ('F')
+ then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ end loop;
+
+ Ungetc (ch, File);
+ end Load_Extended_Digits;
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ Junk : Boolean;
+
+ begin
+ Load_Extended_Digits (File, Buf, Ptr, Junk);
+ end Load_Extended_Digits;
+
+ ---------------
+ -- Load_Skip --
+ ---------------
+
+ procedure Load_Skip (File : File_Type) is
+ C : Character;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- Loop till we find a non-blank character (note that as usual in
+ -- Text_IO, blank includes horizontal tab). Note that Get deals with
+ -- the Before_LM and Before_LM_PM flags appropriately.
+
+ loop
+ Get (File, C);
+ exit when not Is_Blank (C);
+ end loop;
+
+ Ungetc (Character'Pos (C), File);
+ File.Col := File.Col - 1;
+ end Load_Skip;
+
+ ----------------
+ -- Load_Width --
+ ----------------
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : Field;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are immediately before a line mark, then we have no characters.
+ -- This is always a data error, so we may as well raise it right away.
+
+ if File.Before_LM then
+ raise Data_Error;
+
+ else
+ for J in 1 .. Width loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ return;
+
+ elsif ch = LM then
+ Ungetc (ch, File);
+ return;
+
+ else
+ Store_Char (File, ch, Buf, Ptr);
+ end if;
+ end loop;
+ end if;
+ end Load_Width;
+
+ -----------
+ -- Nextc --
+ -----------
+
+ function Nextc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ else
+ return EOF;
+ end if;
+
+ else
+ Ungetc (ch, File);
+ return ch;
+ end if;
+ end Nextc;
+
+ --------------
+ -- Put_Item --
+ --------------
+
+ procedure Put_Item (File : File_Type; Str : String) is
+ begin
+ Check_On_One_Line (File, Str'Length);
+ Put (File, Str);
+ end Put_Item;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : int;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ begin
+ File.Col := File.Col + 1;
+
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := Character'Val (ch);
+ end if;
+ end Store_Char;
+
+ -----------------
+ -- String_Skip --
+ -----------------
+
+ procedure String_Skip (Str : String; Ptr : out Integer) is
+ begin
+ Ptr := Str'First;
+
+ loop
+ if Ptr > Str'Last then
+ raise End_Error;
+
+ elsif not Is_Blank (Str (Ptr)) then
+ return;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+ end String_Skip;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+end Ada.Text_IO.Generic_Aux;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains a set of auxiliary routines used by the Text_IO
+-- generic children, including for reading and writing numeric strings.
+
+private package Ada.Text_IO.Generic_Aux is
+
+ -- Note: for all the Load routines, File indicates the file to be read,
+ -- Buf is the string into which data is stored, Ptr is the index of the
+ -- last character stored so far, and is updated if additional characters
+ -- are stored. Data_Error is raised if the input overflows Buf. The only
+ -- Load routines that do a file status check are Load_Skip and Load_Width
+ -- so one of these two routines must be called first.
+
+ procedure Check_End_Of_Field
+ (File : File_Type;
+ Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field);
+ -- This routine is used after doing a get operations on a numeric value.
+ -- Buf is the string being scanned, and Stop is the last character of
+ -- the field being scanned. Ptr is as set by the call to the scan routine
+ -- that scanned out the numeric value, i.e. it points one past the last
+ -- character scanned, and Width is the width parameter from the Get call.
+ --
+ -- There are two cases, if Width is non-zero, then a check is made that
+ -- the remainder of the field is all blanks. If Width is zero, then it
+ -- means that the scan routine scanned out only part of the field. We
+ -- have already scanned out the field that the ACVC tests seem to expect
+ -- us to read (even if it does not follow the syntax of the type being
+ -- scanned, e.g. allowing negative exponents in integers, and underscores
+ -- at the end of the string), so we just raise Data_Error.
+
+ procedure Check_On_One_Line (File : File_Type; Length : Integer);
+ -- Check to see if item of length Integer characters can fit on
+ -- current line. Call New_Line if not, first checking that the
+ -- line length can accomodate Length characters, raise Layout_Error
+ -- if item is too large for a single line.
+
+ function Getc (File : File_Type) return Integer;
+ -- Gets next character from file, which has already been checked for
+ -- being in read status, and returns the character read if no error
+ -- occurs. The result is EOF if the end of file was read. Note that
+ -- the Col value is not bumped, so it is the caller's responsibility
+ -- to bump it if necessary.
+
+ function Is_Blank (C : Character) return Boolean;
+ -- Determines if C is a blank (space or tab)
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : in Field;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Loads exactly Width characters, unless a line mark is encountered first
+
+ procedure Load_Skip (File : File_Type);
+ -- Skips leading blanks and line and page marks, if the end of file is
+ -- read without finding a non-blank character, then End_Error is raised.
+ -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean);
+ -- If next character is Char, loads it, otherwise no characters are loaded
+ -- Loaded is set to indicate whether or not the character was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean);
+ -- If next character is Char1 or Char2, loads it, otherwise no characters
+ -- are loaded. Loaded is set to indicate whether or not one of the two
+ -- characters was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Loads a sequence of zero or more decimal digits. Loaded is set if
+ -- at least one digit is loaded.
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Like Load_Digits, but also allows extended digits a-f and A-F
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ function Nextc (File : File_Type) return Integer;
+ -- Like Getc, but includes a call to Ungetc, so that the file
+ -- pointer is not moved by the call.
+
+ procedure Put_Item (File : File_Type; Str : String);
+ -- This routine is like Text_IO.Put, except that it checks for overflow
+ -- of bounded lines, as described in (RM A.10.6(8)). It is used for
+ -- all output of numeric values and of enumeration values.
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : Integer;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow and
+ -- adjusting the column number in the file to reflect the fact
+ -- that a character has been acquired from the input stream.
+
+ procedure String_Skip (Str : String; Ptr : out Integer);
+ -- Used in the Get from string procedures to skip leading blanks in the
+ -- string. Ptr is set to the index of the first non-blank. If the string
+ -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- an end of file (EOF) is ignored.
+
+private
+ pragma Inline (Is_Blank);
+
+end Ada.Text_IO.Generic_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+
+package body Ada.Text_IO.Integer_Aux is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Integer
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- integer literal value from the input file into Buf, starting at Ptr + 1.
+ -- On return, Ptr is set to the last character stored.
+
+ -------------
+ -- Get_Int --
+ -------------
+
+ procedure Get_Int
+ (File : in File_Type;
+ Item : out Integer;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_Int;
+
+ -------------
+ -- Get_LLI --
+ -------------
+
+ procedure Get_LLI
+ (File : in File_Type;
+ Item : out Long_Long_Integer;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_LLI;
+
+ --------------
+ -- Gets_Int --
+ --------------
+
+ procedure Gets_Int
+ (From : in String;
+ Item : out Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets_Int;
+
+ --------------
+ -- Gets_LLI --
+ --------------
+
+ procedure Gets_LLI
+ (From : in String;
+ Item : out Long_Long_Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets_LLI;
+
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
+ -------------
+ -- Put_Int --
+ -------------
+
+ procedure Put_Int
+ (File : in File_Type;
+ Item : in Integer;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Integer'Max (Field'Last, Width));
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Int;
+
+ -------------
+ -- Put_LLI --
+ -------------
+
+ procedure Put_LLI
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Integer'Max (Field'Last, Width));
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLI;
+
+ --------------
+ -- Puts_Int --
+ --------------
+
+ procedure Puts_Int
+ (To : out String;
+ Item : in Integer;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Integer'Max (Field'Last, To'Length));
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Int;
+
+ --------------
+ -- Puts_LLI --
+ --------------
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Integer'Max (Field'Last, To'Length));
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLI;
+
+end Ada.Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Text_IO.Integer_IO that are
+-- shared among separate instantiations of this package. The routines in
+-- this package are identical semantically to those in Integer_IO itself,
+-- except that the generic parameter Num has been replaced by Integer or
+-- Long_Long_Integer, and the default parameters have been removed because
+-- they are supplied explicitly by the calls from within the generic template.
+
+private package Ada.Text_IO.Integer_Aux is
+
+ procedure Get_Int
+ (File : in File_Type;
+ Item : out Integer;
+ Width : in Field);
+
+ procedure Get_LLI
+ (File : in File_Type;
+ Item : out Long_Long_Integer;
+ Width : in Field);
+
+ procedure Put_Int
+ (File : in File_Type;
+ Item : in Integer;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Put_LLI
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Gets_Int
+ (From : in String;
+ Item : out Integer;
+ Last : out Positive);
+
+ procedure Gets_LLI
+ (From : in String;
+ Item : out Long_Long_Integer;
+ Last : out Positive);
+
+ procedure Puts_Int
+ (To : out String;
+ Item : in Integer;
+ Base : in Number_Base);
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Base : in Number_Base);
+
+end Ada.Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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.Text_IO.Integer_Aux;
+
+package body Ada.Text_IO.Integer_IO is
+
+ package Aux renames Ada.Text_IO.Integer_Aux;
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ -- Throughout this generic body, we distinguish between the case
+ -- where type Integer is acceptable, and where a Long_Long_Integer
+ -- is needed. This constant Boolean is used to test for these cases
+ -- and since it is a constant, only the code for the relevant case
+ -- will be included in the instance.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLI then
+ Aux.Get_LLI (File, Long_Long_Integer (Item), Width);
+ else
+ Aux.Get_Int (File, Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLI then
+ Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width);
+ else
+ Aux.Get_Int (Current_In, Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ -- We depend on a range check to get Data_Error
+
+ pragma Unsuppress (Range_Check);
+ pragma Unsuppress (Overflow_Check);
+
+ begin
+ if Need_LLI then
+ Aux.Gets_LLI (From, Long_Long_Integer (Item), Last);
+ else
+ Aux.Gets_Int (From, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLI then
+ Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base);
+ else
+ Aux.Put_Int (File, Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLI then
+ Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base);
+ else
+ Aux.Put_Int (Current_Out, Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLI then
+ Aux.Puts_LLI (To, Long_Long_Integer (Item), Base);
+ else
+ Aux.Puts_Int (To, Integer (Item), Base);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Integer_IO is a subpackage of Text_IO.
+-- This is for compatibility with Ada 83. In GNAT we make it a child package
+-- to avoid loading the necessary code if Integer_IO is not instantiated. See
+-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is range <>;
+
+package Ada.Text_IO.Integer_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- 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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+
+package body Ada.Text_IO.Modular_Aux is
+
+ use System.Unsigned_Types;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Modular
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- modular literal value from the input file into Buf, starting at Ptr + 1.
+ -- Ptr is left set to the last character stored.
+
+ -------------
+ -- Get_LLU --
+ -------------
+
+ procedure Get_LLU
+ (File : File_Type;
+ Item : out Long_Long_Unsigned;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_LLU;
+
+ -------------
+ -- Get_Uns --
+ -------------
+
+ procedure Get_Uns
+ (File : File_Type;
+ Item : out Unsigned;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_Uns;
+
+ --------------
+ -- Gets_LLU --
+ --------------
+
+ procedure Gets_LLU
+ (From : String;
+ Item : out Long_Long_Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets_LLU;
+
+ --------------
+ -- Gets_Uns --
+ --------------
+
+ procedure Gets_Uns
+ (From : String;
+ Item : out Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets_Uns;
+
+ ------------------
+ -- Load_Modular --
+ ------------------
+
+ procedure Load_Modular
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Modular;
+
+ -------------
+ -- Put_LLU --
+ -------------
+
+ procedure Put_LLU
+ (File : File_Type;
+ Item : Long_Long_Unsigned;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLU;
+
+ -------------
+ -- Put_Uns --
+ -------------
+
+ procedure Put_Uns
+ (File : File_Type;
+ Item : Unsigned;
+ Width : Field;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Uns;
+
+ --------------
+ -- Puts_LLU --
+ --------------
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : Long_Long_Unsigned;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLU;
+
+ --------------
+ -- Puts_Uns --
+ --------------
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : Unsigned;
+ Base : Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Uns;
+
+end Ada.Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Text_IO.Modular_IO that are
+-- shared among separate instantiations of this package. The routines in
+-- this package are identical semantically to those in Modular_IO itself,
+-- except that the generic parameter Num has been replaced by Unsigned or
+-- Long_Long_Unsigned, and the default parameters have been removed because
+-- they are supplied explicitly by the calls from within the generic template.
+
+with System.Unsigned_Types;
+
+private package Ada.Text_IO.Modular_Aux is
+
+ package U renames System.Unsigned_Types;
+
+ procedure Get_Uns
+ (File : File_Type;
+ Item : out U.Unsigned;
+ Width : Field);
+
+ procedure Get_LLU
+ (File : File_Type;
+ Item : out U.Long_Long_Unsigned;
+ Width : Field);
+
+ procedure Put_Uns
+ (File : File_Type;
+ Item : U.Unsigned;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Put_LLU
+ (File : File_Type;
+ Item : U.Long_Long_Unsigned;
+ Width : Field;
+ Base : Number_Base);
+
+ procedure Gets_Uns
+ (From : String;
+ Item : out U.Unsigned;
+ Last : out Positive);
+
+ procedure Gets_LLU
+ (From : String;
+ Item : out U.Long_Long_Unsigned;
+ Last : out Positive);
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : U.Unsigned;
+ Base : Number_Base);
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : U.Long_Long_Unsigned;
+ Base : Number_Base);
+
+end Ada.Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Text_IO.Modular_Aux;
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+
+package body Ada.Text_IO.Modular_IO is
+
+ package Aux renames Ada.Text_IO.Modular_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Get_LLU (File, Long_Long_Unsigned (Item), Width);
+ else
+ Aux.Get_Uns (File, Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Get_LLU (Current_In, Long_Long_Unsigned (Item), Width);
+ else
+ Aux.Get_Uns (Current_In, Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ pragma Unsuppress (Range_Check);
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Gets_LLU (From, Long_Long_Unsigned (Item), Last);
+ else
+ Aux.Gets_Uns (From, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Put_LLU (File, Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux.Put_Uns (File, Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Put_LLU (Current_Out, Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux.Put_Uns (Current_Out, Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Puts_LLU (To, Long_Long_Unsigned (Item), Base);
+ else
+ Aux.Puts_Uns (To, Unsigned (Item), Base);
+ end if;
+ end Put;
+
+end Ada.Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1993-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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Text_IO.Modular_IO is a subpackage of Text_IO.
+-- This is for compatibility with Ada 83. In GNAT we make it a child package
+-- to avoid loading the necessary code if Modular_IO is not instantiated. See
+-- routine Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is mod <>;
+
+package Ada.Text_IO.Modular_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Get
+ (From : in String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base);
+
+private
+ pragma Inline (Get);
+ pragma Inline (Put);
+
+end Ada.Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . T E X T _ 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.Text_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 : Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => "",
+ Form => Form,
+ Amethod => 'T',
+ Creat => False,
+ Text => True,
+ C_Stream => C_Stream);
+ end Open;
+
+end Ada.Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X 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.Text_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.Text_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.Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . T E X T _ S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.File_IO;
+
+package body Ada.Text_IO.Text_Streams is
+
+ ------------
+ -- Stream --
+ ------------
+
+ function Stream (File : in File_Type) return Stream_Access is
+ begin
+ System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File));
+ return Stream_Access (File);
+ end Stream;
+
+end Ada.Text_IO.Text_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . T E X T _ S T R E A M S --
+-- --
+-- 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.Streams;
+package Ada.Text_IO.Text_Streams is
+
+ type Stream_Access is access all Streams.Root_Stream_Type'Class;
+
+ function Stream (File : in File_Type) return Stream_Access;
+
+end Ada.Text_IO.Text_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . U N C H E C K E D _ C O N V E R S I O N --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Source (<>) is limited private;
+ type Target (<>) is limited private;
+
+function Ada.Unchecked_Conversion (S : Source) return Target;
+
+pragma Pure (Unchecked_Conversion);
+pragma Import (Intrinsic, Unchecked_Conversion);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . U N C H E C K E D _ D E A L L O C A T I O N --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+ type Object (<>) is limited private;
+ type Name is access Object;
+
+procedure Ada.Unchecked_Deallocation (X : in out Name);
+pragma Preelaborate (Unchecked_Deallocation);
+
+pragma Import (Intrinsic, Unchecked_Deallocation);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.25 $
+-- --
+-- 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.Exceptions; use Ada.Exceptions;
+with Ada.Streams; use Ada.Streams;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+
+with System;
+with System.File_IO;
+with System.WCh_Cnv; use System.WCh_Cnv;
+with System.WCh_Con; use System.WCh_Con;
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+pragma Elaborate_All (System.File_IO);
+-- Needed because of calls to Chain_File in package body elaboration
+
+package body Ada.Wide_Text_IO is
+
+ package FIO renames System.File_IO;
+
+ subtype AP is FCB.AFCB_Ptr;
+
+ function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
+ function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
+ use type FCB.File_Mode;
+
+ WC_Encoding : Character;
+ pragma Import (C, WC_Encoding, "__gl_wc_encoding");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Getc_Immed (File : in File_Type) return int;
+ -- This routine is identical to Getc, except that the read is done in
+ -- Get_Immediate mode (i.e. without waiting for a line return).
+
+ function Get_Wide_Char_Immed
+ (C : Character;
+ File : File_Type)
+ return Wide_Character;
+ -- This routine is identical to Get_Wide_Char, except that the reads are
+ -- done in Get_Immediate mode (i.e. without waiting for a line return).
+
+ procedure Set_WCEM (File : in out File_Type);
+ -- Called by Open and Create to set the wide character encoding method
+ -- for the file, processing a WCEM form parameter if one is present.
+ -- File is IN OUT because it may be closed in case of an error.
+
+ -------------------
+ -- AFCB_Allocate --
+ -------------------
+
+ function AFCB_Allocate
+ (Control_Block : Wide_Text_AFCB)
+ return FCB.AFCB_Ptr
+ is
+ begin
+ return new Wide_Text_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ procedure AFCB_Close (File : access Wide_Text_AFCB) is
+ begin
+ -- If the file being closed is one of the current files, then close
+ -- the corresponding current file. It is not clear that this action
+ -- is required (RM A.10.3(23)) but it seems reasonable, and besides
+ -- ACVC test CE3208A expects this behavior.
+
+ if File_Type (File) = Current_In then
+ Current_In := null;
+ elsif File_Type (File) = Current_Out then
+ Current_Out := null;
+ elsif File_Type (File) = Current_Err then
+ Current_Err := null;
+ end if;
+
+ Terminate_Line (File_Type (File));
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Wide_Text_AFCB) is
+ type FCB_Ptr is access all Wide_Text_AFCB;
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out File_Type) is
+ begin
+ FIO.Close (AP (File));
+ end Close;
+
+ ---------
+ -- Col --
+ ---------
+
+ -- Note: we assume that it is impossible in practice for the column
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Col (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Col;
+ end Col;
+
+ function Col return Positive_Count is
+ begin
+ return Col (Current_Out);
+ end Col;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : in File_Mode := Out_File;
+ Name : in String := "";
+ Form : in String := "")
+ is
+ File_Control_Block : Wide_Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'W',
+ Creat => True,
+ Text => True);
+ Set_WCEM (File);
+ end Create;
+
+ -------------------
+ -- Current_Error --
+ -------------------
+
+ function Current_Error return File_Type is
+ begin
+ return Current_Err;
+ end Current_Error;
+
+ function Current_Error return File_Access is
+ begin
+ return Current_Err'Access;
+ end Current_Error;
+
+ -------------------
+ -- Current_Input --
+ -------------------
+
+ function Current_Input return File_Type is
+ begin
+ return Current_In;
+ end Current_Input;
+
+ function Current_Input return File_Access is
+ begin
+ return Current_In'Access;
+ end Current_Input;
+
+ --------------------
+ -- Current_Output --
+ --------------------
+
+ function Current_Output return File_Type is
+ begin
+ return Current_Out;
+ end Current_Output;
+
+ function Current_Output return File_Access is
+ begin
+ return Current_Out'Access;
+ end Current_Output;
+
+ ------------
+ -- 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
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+
+ if File.Before_LM_PM then
+ return Nextc (File) = EOF;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Before_LM_PM := True;
+ return Nextc (File) = EOF;
+
+ -- Here if neither EOF nor PM followed end of line
+
+ else
+ Ungetc (ch, File);
+ return False;
+ end if;
+
+ end End_Of_File;
+
+ function End_Of_File return Boolean is
+ begin
+ return End_Of_File (Current_In);
+ end End_Of_File;
+
+ -----------------
+ -- End_Of_Line --
+ -----------------
+
+ function End_Of_Line (File : in File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+ return True;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ else
+ Ungetc (ch, File);
+ return (ch = LM);
+ end if;
+ end if;
+ end End_Of_Line;
+
+ function End_Of_Line return Boolean is
+ begin
+ return End_Of_Line (Current_In);
+ end End_Of_Line;
+
+ -----------------
+ -- End_Of_Page --
+ -----------------
+
+ function End_Of_Page (File : in File_Type) return Boolean is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if not File.Is_Regular_File then
+ return False;
+
+ elsif File.Before_Wide_Character then
+ return False;
+
+ elsif File.Before_LM then
+ if File.Before_LM_PM then
+ return True;
+ end if;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ return True;
+
+ elsif ch /= LM then
+ Ungetc (ch, File);
+ return False;
+
+ else -- ch = LM
+ File.Before_LM := True;
+ end if;
+ end if;
+
+ -- Here we are just past the line mark with Before_LM set so that we
+ -- do not have to try to back up past the LM, thus avoiding the need
+ -- to back up more than one character.
+
+ ch := Nextc (File);
+
+ return ch = PM or else ch = EOF;
+ end End_Of_Page;
+
+ function End_Of_Page return Boolean is
+ begin
+ return End_Of_Page (Current_In);
+ end End_Of_Page;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : in File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
+ procedure Flush is
+ begin
+ Flush (Current_Out);
+ end Flush;
+
+ ----------
+ -- Form --
+ ----------
+
+ function Form (File : in File_Type) return String is
+ begin
+ return FIO.Form (AP (File));
+ end Form;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Wide_Character)
+ is
+ C : Character;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Character then
+ File.Before_Wide_Character := False;
+ Item := File.Saved_Wide_Character;
+
+ else
+ Get_Character (File, C);
+ Item := Get_Wide_Char (C, File);
+ end if;
+ end Get;
+
+ procedure Get (Item : out Wide_Character) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Wide_String)
+ is
+ begin
+ for J in Item'Range loop
+ Get (File, Item (J));
+ end loop;
+ end Get;
+
+ procedure Get (Item : out Wide_String) is
+ begin
+ Get (Current_In, Item);
+ end Get;
+
+ -------------------
+ -- Get_Character --
+ -------------------
+
+ procedure Get_Character
+ (File : in File_Type;
+ Item : out Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Col := 1;
+
+ if File.Before_LM_PM then
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ File.Before_LM_PM := False;
+
+ else
+ File.Line := File.Line + 1;
+ end if;
+ end if;
+
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+
+ else
+ Item := Character'Val (ch);
+ File.Col := File.Col + 1;
+ return;
+ end if;
+ end loop;
+ end Get_Character;
+
+ -------------------
+ -- Get_Immediate --
+ -------------------
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Wide_Character)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_Wide_Character then
+ File.Before_Wide_Character := False;
+ Item := File.Saved_Wide_Character;
+
+ elsif File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ Item := Wide_Character'Val (LM);
+
+ else
+ ch := Getc_Immed (File);
+
+ if ch = EOF then
+ raise End_Error;
+ else
+ Item := Get_Wide_Char_Immed (Character'Val (ch), File);
+ end if;
+ end if;
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Wide_Character)
+ is
+ begin
+ Get_Immediate (Current_In, Item);
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Wide_Character;
+ Available : out Boolean)
+ is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Available := True;
+
+ if File.Before_Wide_Character then
+ File.Before_Wide_Character := False;
+ Item := File.Saved_Wide_Character;
+
+ elsif File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ Item := Wide_Character'Val (LM);
+
+ else
+ ch := Getc_Immed (File);
+
+ if ch = EOF then
+ raise End_Error;
+ else
+ Item := Get_Wide_Char_Immed (Character'Val (ch), File);
+ end if;
+ end if;
+ end Get_Immediate;
+
+ procedure Get_Immediate
+ (Item : out Wide_Character;
+ Available : out Boolean)
+ is
+ begin
+ Get_Immediate (Current_In, Item, Available);
+ end Get_Immediate;
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ procedure Get_Line
+ (File : in File_Type;
+ Item : out Wide_String;
+ Last : out Natural)
+ is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Last := Item'First - 1;
+
+ -- Immediate exit for null string, this is a case in which we do not
+ -- need to test for end of file and we do not skip a line mark under
+ -- any circumstances.
+
+ if Last >= Item'Last then
+ return;
+ end if;
+
+ -- Here we have at least one character, if we are immediately before
+ -- a line mark, then we will just skip past it storing no characters.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ -- Otherwise we need to read some characters
+
+ else
+ -- If we are at the end of file now, it means we are trying to
+ -- skip a file terminator and we raise End_Error (RM A.10.7(20))
+
+ if Nextc (File) = EOF then
+ raise End_Error;
+ end if;
+
+ -- Loop through characters in string
+
+ loop
+ -- Exit the loop if read is terminated by encountering line mark
+ -- Note that the use of Skip_Line here ensures we properly deal
+ -- with setting the page and line numbers.
+
+ if End_Of_Line (File) then
+ Skip_Line (File);
+ return;
+ end if;
+
+ -- Otherwise store the character, note that we know that ch is
+ -- something other than LM or EOF. It could possibly be a page
+ -- mark if there is a stray page mark in the middle of a line,
+ -- but this is not an official page mark in any case, since
+ -- official page marks can only follow a line mark. The whole
+ -- page business is pretty much nonsense anyway, so we do not
+ -- want to waste time trying to make sense out of non-standard
+ -- page marks in the file! This means that the behavior of
+ -- Get_Line is different from repeated Get of a character, but
+ -- that's too bad. We only promise that page numbers etc make
+ -- sense if the file is formatted in a standard manner.
+
+ -- Note: we do not adjust the column number because it is quicker
+ -- to adjust it once at the end of the operation than incrementing
+ -- it each time around the loop.
+
+ Last := Last + 1;
+ Get (File, Item (Last));
+
+ -- All done if the string is full, this is the case in which
+ -- we do not skip the following line mark. We need to adjust
+ -- the column number in this case.
+
+ if Last = Item'Last then
+ File.Col := File.Col + Count (Item'Length);
+ return;
+ end if;
+
+ -- Exit from the loop if we are at the end of file. This happens
+ -- if we have a last line that is not terminated with a line mark.
+ -- In this case we consider that there is an implied line mark;
+ -- this is a non-standard file, but we will treat it nicely.
+
+ exit when Nextc (File) = EOF;
+ end loop;
+ end if;
+ end Get_Line;
+
+ procedure Get_Line
+ (Item : out Wide_String;
+ Last : out Natural)
+ is
+ begin
+ Get_Line (Current_In, Item, Last);
+ end Get_Line;
+
+ -------------------
+ -- Get_Wide_Char --
+ -------------------
+
+ function Get_Wide_Char
+ (C : Character;
+ File : File_Type)
+ return Wide_Character
+ is
+ function In_Char return Character;
+ -- Function used to obtain additional characters it the wide character
+ -- sequence is more than one character long.
+
+ function In_Char return Character is
+ ch : constant Integer := Getc (File);
+
+ begin
+ if ch = EOF then
+ raise End_Error;
+ else
+ return Character'Val (ch);
+ end if;
+ end In_Char;
+
+ function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
+
+ begin
+ return WC_In (C, File.WC_Method);
+ end Get_Wide_Char;
+
+ -------------------------
+ -- Get_Wide_Char_Immed --
+ -------------------------
+
+ function Get_Wide_Char_Immed
+ (C : Character;
+ File : File_Type)
+ return Wide_Character
+ is
+ function In_Char return Character;
+ -- Function used to obtain additional characters it the wide character
+ -- sequence is more than one character long.
+
+ function In_Char return Character is
+ ch : constant Integer := Getc_Immed (File);
+
+ begin
+ if ch = EOF then
+ raise End_Error;
+ else
+ return Character'Val (ch);
+ end if;
+ end In_Char;
+
+ function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
+
+ begin
+ return WC_In (C, File.WC_Method);
+ end Get_Wide_Char_Immed;
+
+ ----------
+ -- Getc --
+ ----------
+
+ function Getc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF and then ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ else
+ return ch;
+ end if;
+ end Getc;
+
+ ----------------
+ -- Getc_Immed --
+ ----------------
+
+ function Getc_Immed (File : in File_Type) return int is
+ ch : int;
+ end_of_file : int;
+
+ procedure getc_immediate
+ (stream : FILEs; ch : out int; end_of_file : out int);
+ pragma Import (C, getc_immediate, "getc_immediate");
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := LM;
+
+ else
+ getc_immediate (File.Stream, ch, end_of_file);
+
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ elsif end_of_file /= 0 then
+ return EOF;
+ end if;
+ end if;
+
+ return ch;
+ end Getc_Immed;
+
+ -------------
+ -- Is_Open --
+ -------------
+
+ function Is_Open (File : in File_Type) return Boolean is
+ begin
+ return FIO.Is_Open (AP (File));
+ end Is_Open;
+
+ ----------
+ -- Line --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the line
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Line (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Line;
+ end Line;
+
+ function Line return Positive_Count is
+ begin
+ return Line (Current_Out);
+ end Line;
+
+ -----------------
+ -- Line_Length --
+ -----------------
+
+ function Line_Length (File : in File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Line_Length;
+ end Line_Length;
+
+ function Line_Length return Count is
+ begin
+ return Line_Length (Current_Out);
+ end Line_Length;
+
+ ----------------
+ -- Look_Ahead --
+ ----------------
+
+ procedure Look_Ahead
+ (File : in File_Type;
+ Item : out Wide_Character;
+ End_Of_Line : out Boolean)
+ is
+ ch : int;
+
+ -- Start of processing for Look_Ahead
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are logically before a line mark, we can return immediately
+
+ if File.Before_LM then
+ End_Of_Line := True;
+ Item := Wide_Character'Val (0);
+
+ -- If we are before a wide character, just return it (this happens
+ -- if there are two calls to Look_Ahead in a row).
+
+ elsif File.Before_Wide_Character then
+ End_Of_Line := False;
+ Item := File.Saved_Wide_Character;
+
+ -- otherwise we must read a character from the input stream
+
+ else
+ ch := Getc (File);
+
+ if ch = LM
+ or else ch = EOF
+ or else (ch = EOF and then File.Is_Regular_File)
+ then
+ End_Of_Line := True;
+ Ungetc (ch, File);
+ Item := Wide_Character'Val (0);
+
+ -- If the character is in the range 16#0000# to 16#007F# it stands
+ -- for itself and occupies a single byte, so we can unget it with
+ -- no difficulty.
+
+ elsif ch <= 16#0080# then
+ End_Of_Line := False;
+ Ungetc (ch, File);
+ Item := Wide_Character'Val (ch);
+
+ -- For a character above this range, we read the character, using
+ -- the Get_Wide_Char routine. It may well occupy more than one byte
+ -- so we can't put it back with ungetc. Instead we save it in the
+ -- control block, setting a flag that everyone interested in reading
+ -- characters must test before reading the stream.
+
+ else
+ Item := Get_Wide_Char (Character'Val (ch), File);
+ End_Of_Line := False;
+ File.Saved_Wide_Character := Item;
+ File.Before_Wide_Character := True;
+ end if;
+ end if;
+ end Look_Ahead;
+
+ procedure Look_Ahead
+ (Item : out Wide_Character;
+ End_Of_Line : out Boolean)
+ is
+ begin
+ Look_Ahead (Current_In, Item, End_Of_Line);
+ end Look_Ahead;
+
+ ----------
+ -- Mode --
+ ----------
+
+ function Mode (File : in File_Type) return File_Mode is
+ begin
+ return To_TIO (FIO.Mode (AP (File)));
+ end Mode;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (File : in File_Type) return String is
+ begin
+ return FIO.Name (AP (File));
+ end Name;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line
+ (File : in File_Type;
+ Spacing : in Positive_Count := 1)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+
+ for K in 1 .. Spacing loop
+ Putc (LM, File);
+ File.Line := File.Line + 1;
+
+ if File.Page_Length /= 0
+ and then File.Line > File.Page_Length
+ then
+ Putc (PM, File);
+ File.Line := 1;
+ File.Page := File.Page + 1;
+ end if;
+ end loop;
+
+ File.Col := 1;
+ end New_Line;
+
+ procedure New_Line (Spacing : in Positive_Count := 1) is
+ begin
+ New_Line (Current_Out, Spacing);
+ end New_Line;
+
+ --------------
+ -- New_Page --
+ --------------
+
+ procedure New_Page (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Col /= 1 or else File.Line = 1 then
+ Putc (LM, File);
+ end if;
+
+ Putc (PM, File);
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ end New_Page;
+
+ procedure New_Page is
+ begin
+ New_Page (Current_Out);
+ end New_Page;
+
+ -----------
+ -- Nextc --
+ -----------
+
+ function Nextc (File : File_Type) return int is
+ ch : int;
+
+ begin
+ ch := fgetc (File.Stream);
+
+ if ch = EOF then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+
+ else
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+
+ return ch;
+ end Nextc;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : in File_Mode;
+ Name : in String;
+ Form : in String := "")
+ is
+ File_Control_Block : Wide_Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => Name,
+ Form => Form,
+ Amethod => 'W',
+ Creat => False,
+ Text => True);
+ Set_WCEM (File);
+ end Open;
+
+ ----------
+ -- Page --
+ ----------
+
+ -- Note: we assume that it is impossible in practice for the page
+ -- to exceed the value of Count'Last, i.e. no check is required for
+ -- overflow raising layout error.
+
+ function Page (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return File.Page;
+ end Page;
+
+ function Page return Positive_Count is
+ begin
+ return Page (Current_Out);
+ end Page;
+
+ -----------------
+ -- Page_Length --
+ -----------------
+
+ function Page_Length (File : in File_Type) return Count is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ return File.Page_Length;
+ end Page_Length;
+
+ function Page_Length return Count is
+ begin
+ return Page_Length (Current_Out);
+ end Page_Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Wide_Character)
+ is
+ procedure Out_Char (C : Character);
+ -- Procedure to output one character of a wide character sequence
+
+ procedure Out_Char (C : Character) is
+ begin
+ Putc (Character'Pos (C), File);
+ end Out_Char;
+
+ procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
+
+ begin
+ WC_Out (Item, File.WC_Method);
+ File.Col := File.Col + 1;
+ end Put;
+
+ procedure Put (Item : in Wide_Character) is
+ begin
+ Put (Current_Out, Item);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Wide_String)
+ is
+ begin
+ for J in Item'Range loop
+ Put (File, Item (J));
+ end loop;
+ end Put;
+
+ procedure Put (Item : in Wide_String) is
+ begin
+ Put (Current_Out, Item);
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line
+ (File : in File_Type;
+ Item : in Wide_String)
+ is
+ begin
+ Put (File, Item);
+ New_Line (File);
+ end Put_Line;
+
+ procedure Put_Line (Item : in Wide_String) is
+ begin
+ Put (Current_Out, Item);
+ New_Line (Current_Out);
+ end Put_Line;
+
+ ----------
+ -- Putc --
+ ----------
+
+ procedure Putc (ch : int; File : File_Type) is
+ begin
+ if fputc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end Putc;
+
+ ----------
+ -- Read --
+ ----------
+
+ -- This is the primitive Stream Read routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Read
+ (File : in out Wide_Text_AFCB;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ ch : int;
+
+ begin
+ -- Need to deal with Before_Wide_Character ???
+
+ if File.Mode /= FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Deal with case where our logical and physical position do not match
+ -- because of being after an LM or LM-PM sequence when in fact we are
+ -- logically positioned before it.
+
+ if File.Before_LM then
+
+ -- If we are before a PM, then it is possible for a stream read
+ -- to leave us after the LM and before the PM, which is a bit
+ -- odd. The easiest way to deal with this is to unget the PM,
+ -- so we are indeed positioned between the characters. This way
+ -- further stream read operations will work correctly, and the
+ -- effect on text processing is a little weird, but what can
+ -- be expected if stream and text input are mixed this way?
+
+ if File.Before_LM_PM then
+ ch := ungetc (PM, File.Stream);
+ File.Before_LM_PM := False;
+ end if;
+
+ File.Before_LM := False;
+
+ Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
+
+ if Item'Length = 1 then
+ Last := Item'Last;
+
+ else
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (buffer => Item'Address,
+ index => size_t (Item'First + 1),
+ size => 1,
+ count => Item'Length - 1,
+ stream => File.Stream));
+ end if;
+
+ return;
+ end if;
+
+ -- Now we do the read. Since this is a text file, it is normally in
+ -- text mode, but stream data must be read in binary mode, so we
+ -- temporarily set binary mode for the read, resetting it after.
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ set_binary_mode (fileno (File.Stream));
+
+ Last :=
+ Item'First +
+ Stream_Element_Offset
+ (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
+
+ if Last < Item'Last then
+ if ferror (File.Stream) /= 0 then
+ raise Device_Error;
+ end if;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end Read;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset
+ (File : in out File_Type;
+ Mode : in File_Mode)
+ is
+ begin
+ -- Don't allow change of mode for current file (RM A.10.2(5))
+
+ if (File = Current_In or else
+ File = Current_Out or else
+ File = Current_Error)
+ and then To_FCB (Mode) /= File.Mode
+ then
+ raise Mode_Error;
+ end if;
+
+ Terminate_Line (File);
+ FIO.Reset (AP (File), To_FCB (Mode));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ procedure Reset (File : in out File_Type) is
+ begin
+ Terminate_Line (File);
+ FIO.Reset (AP (File));
+ File.Page := 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Line_Length := 0;
+ File.Page_Length := 0;
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ end Reset;
+
+ -------------
+ -- Set_Col --
+ -------------
+
+ procedure Set_Col
+ (File : in File_Type;
+ To : in Positive_Count)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Col then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Line_Length /= 0 and then To > File.Line_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Col then
+ New_Line (File);
+ end if;
+
+ while File.Col < To loop
+ Put (File, ' ');
+ end loop;
+
+ else
+ loop
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+
+ elsif ch = LM then
+ File.Line := File.Line + 1;
+ File.Col := 1;
+
+ elsif ch = PM and then File.Is_Regular_File then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+
+ elsif To = File.Col then
+ Ungetc (ch, File);
+ return;
+
+ else
+ File.Col := File.Col + 1;
+ end if;
+ end loop;
+ end if;
+ end Set_Col;
+
+ procedure Set_Col (To : in Positive_Count) is
+ begin
+ Set_Col (Current_Out, To);
+ end Set_Col;
+
+ ---------------
+ -- Set_Error --
+ ---------------
+
+ procedure Set_Error (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Err := File;
+ end Set_Error;
+
+ ---------------
+ -- Set_Input --
+ ---------------
+
+ procedure Set_Input (File : in File_Type) is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ Current_In := File;
+ end Set_Input;
+
+ --------------
+ -- Set_Line --
+ --------------
+
+ procedure Set_Line
+ (File : in File_Type;
+ To : in Positive_Count)
+ is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_File_Open (AP (File));
+
+ if To = File.Line then
+ return;
+ end if;
+
+ if Mode (File) >= Out_File then
+ if File.Page_Length /= 0 and then To > File.Page_Length then
+ raise Layout_Error;
+ end if;
+
+ if To < File.Line then
+ New_Page (File);
+ end if;
+
+ while File.Line < To loop
+ New_Line (File);
+ end loop;
+
+ else
+ while To /= File.Line loop
+ Skip_Line (File);
+ end loop;
+ end if;
+ end Set_Line;
+
+ procedure Set_Line (To : in Positive_Count) is
+ begin
+ Set_Line (Current_Out, To);
+ end Set_Line;
+
+ ---------------------
+ -- Set_Line_Length --
+ ---------------------
+
+ procedure Set_Line_Length (File : in File_Type; To : in Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Line_Length := To;
+ end Set_Line_Length;
+
+ procedure Set_Line_Length (To : in Count) is
+ begin
+ Set_Line_Length (Current_Out, To);
+ end Set_Line_Length;
+
+ ----------------
+ -- Set_Output --
+ ----------------
+
+ procedure Set_Output (File : in File_Type) is
+ begin
+ FIO.Check_Write_Status (AP (File));
+ Current_Out := File;
+ end Set_Output;
+
+ ---------------------
+ -- Set_Page_Length --
+ ---------------------
+
+ procedure Set_Page_Length (File : in File_Type; To : in Count) is
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if To not in Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Write_Status (AP (File));
+ File.Page_Length := To;
+ end Set_Page_Length;
+
+ procedure Set_Page_Length (To : in Count) is
+ begin
+ Set_Page_Length (Current_Out, To);
+ end Set_Page_Length;
+
+ --------------
+ -- Set_WCEM --
+ --------------
+
+ procedure Set_WCEM (File : in out File_Type) is
+ Start : Natural;
+ Stop : Natural;
+
+ begin
+ File.WC_Method := WCEM_Brackets;
+ FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
+
+ if Start = 0 then
+ File.WC_Method := WCEM_Brackets;
+
+ elsif Start /= 0 then
+ if Stop = Start then
+ for J in WC_Encoding_Letters'Range loop
+ if File.Form (Start) = WC_Encoding_Letters (J) then
+ File.WC_Method := J;
+ return;
+ end if;
+ end loop;
+ end if;
+
+ Close (File);
+ Raise_Exception (Use_Error'Identity, "invalid WCEM form parameter");
+ end if;
+ end Set_WCEM;
+
+ ---------------
+ -- Skip_Line --
+ ---------------
+
+ procedure Skip_Line
+ (File : in File_Type;
+ Spacing : in Positive_Count := 1)
+ is
+ ch : int;
+
+ begin
+ -- Raise Constraint_Error if out of range value. The reason for this
+ -- explicit test is that we don't want junk values around, even if
+ -- checks are off in the caller.
+
+ if Spacing not in Positive_Count then
+ raise Constraint_Error;
+ end if;
+
+ FIO.Check_Read_Status (AP (File));
+
+ for L in 1 .. Spacing loop
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+
+ else
+ ch := Getc (File);
+
+ -- If at end of file now, then immediately raise End_Error. Note
+ -- that we can never be positioned between a line mark and a page
+ -- mark, so if we are at the end of file, we cannot logically be
+ -- before the implicit page mark that is at the end of the file.
+
+ -- For the same reason, we do not need an explicit check for a
+ -- page mark. If there is a FF in the middle of a line, the file
+ -- is not in canonical format and we do not care about the page
+ -- numbers for files other than ones in canonical format.
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+
+ -- If not at end of file, then loop till we get to an LM or EOF.
+ -- The latter case happens only in non-canonical files where the
+ -- last line is not terminated by LM, but we don't want to blow
+ -- up for such files, so we assume an implicit LM in this case.
+
+ loop
+ exit when ch = LM or ch = EOF;
+ ch := Getc (File);
+ end loop;
+ end if;
+
+ -- We have got past a line mark, now, for a regular file only,
+ -- see if a page mark immediately follows this line mark and
+ -- if so, skip past the page mark as well. We do not do this
+ -- for non-regular files, since it would cause an undesirable
+ -- wait for an additional character.
+
+ File.Col := 1;
+ File.Line := File.Line + 1;
+
+ if File.Before_LM_PM then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Before_LM_PM := False;
+
+ elsif File.Is_Regular_File then
+ ch := Getc (File);
+
+ -- Page mark can be explicit, or implied at the end of the file
+
+ if (ch = PM or else ch = EOF)
+ and then File.Is_Regular_File
+ then
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+
+ end loop;
+
+ File.Before_Wide_Character := False;
+ end Skip_Line;
+
+ procedure Skip_Line (Spacing : in Positive_Count := 1) is
+ begin
+ Skip_Line (Current_In, Spacing);
+ end Skip_Line;
+
+ ---------------
+ -- Skip_Page --
+ ---------------
+
+ procedure Skip_Page (File : in File_Type) is
+ ch : int;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If at page mark already, just skip it
+
+ if File.Before_LM_PM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ return;
+ end if;
+
+ -- This is a bit tricky, if we are logically before an LM then
+ -- it is not an error if we are at an end of file now, since we
+ -- are not really at it.
+
+ if File.Before_LM then
+ File.Before_LM := False;
+ File.Before_LM_PM := False;
+ ch := Getc (File);
+
+ -- Otherwise we do raise End_Error if we are at the end of file now
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ raise End_Error;
+ end if;
+ end if;
+
+ -- Now we can just rumble along to the next page mark, or to the
+ -- end of file, if that comes first. The latter case happens when
+ -- the page mark is implied at the end of file.
+
+ loop
+ exit when ch = EOF
+ or else (ch = PM and then File.Is_Regular_File);
+ ch := Getc (File);
+ end loop;
+
+ File.Page := File.Page + 1;
+ File.Line := 1;
+ File.Col := 1;
+ File.Before_Wide_Character := False;
+ end Skip_Page;
+
+ procedure Skip_Page is
+ begin
+ Skip_Page (Current_In);
+ end Skip_Page;
+
+ --------------------
+ -- Standard_Error --
+ --------------------
+
+ function Standard_Error return File_Type is
+ begin
+ return Standard_Err;
+ end Standard_Error;
+
+ function Standard_Error return File_Access is
+ begin
+ return Standard_Err'Access;
+ end Standard_Error;
+
+ --------------------
+ -- Standard_Input --
+ --------------------
+
+ function Standard_Input return File_Type is
+ begin
+ return Standard_In;
+ end Standard_Input;
+
+ function Standard_Input return File_Access is
+ begin
+ return Standard_In'Access;
+ end Standard_Input;
+
+ ---------------------
+ -- Standard_Output --
+ ---------------------
+
+ function Standard_Output return File_Type is
+ begin
+ return Standard_Out;
+ end Standard_Output;
+
+ function Standard_Output return File_Access is
+ begin
+ return Standard_Out'Access;
+ end Standard_Output;
+
+ --------------------
+ -- Terminate_Line --
+ --------------------
+
+ procedure Terminate_Line (File : File_Type) is
+ begin
+ FIO.Check_File_Open (AP (File));
+
+ -- For file other than In_File, test for needing to terminate last line
+
+ if Mode (File) /= In_File then
+
+ -- If not at start of line definition need new line
+
+ if File.Col /= 1 then
+ New_Line (File);
+
+ -- For files other than standard error and standard output, we
+ -- make sure that an empty file has a single line feed, so that
+ -- it is properly formatted. We avoid this for the standard files
+ -- because it is too much of a nuisance to have these odd line
+ -- feeds when nothing has been written to the file.
+
+ elsif (File /= Standard_Err and then File /= Standard_Out)
+ and then (File.Line = 1 and then File.Page = 1)
+ then
+ New_Line (File);
+ end if;
+ end if;
+ end Terminate_Line;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+ -----------
+ -- Write --
+ -----------
+
+ -- This is the primitive Stream Write routine, used when a Text_IO file
+ -- is treated directly as a stream using Text_IO.Streams.Stream.
+
+ procedure Write
+ (File : in out Wide_Text_AFCB;
+ Item : in Stream_Element_Array)
+ is
+ Siz : constant size_t := Item'Length;
+
+ begin
+ if File.Mode = FCB.In_File then
+ raise Mode_Error;
+ end if;
+
+ -- Now we do the write. Since this is a text file, it is normally in
+ -- text mode, but stream data must be written in binary mode, so we
+ -- temporarily set binary mode for the write, resetting it after.
+ -- These calls have no effect in a system (like Unix) where there is
+ -- no distinction between text and binary files.
+
+ set_binary_mode (fileno (File.Stream));
+
+ if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
+ raise Device_Error;
+ end if;
+
+ set_text_mode (fileno (File.Stream));
+ end Write;
+
+ -- Use "preallocated" strings to avoid calling "new" during the
+ -- elaboration of the run time. This is needed in the tasking case to
+ -- avoid calling Task_Lock too early. A filename is expected to end with
+ -- a null character in the runtime, here the null characters are added
+ -- just to have a correct filename length.
+
+ Err_Name : aliased String := "*stderr" & ASCII.Nul;
+ In_Name : aliased String := "*stdin" & ASCII.Nul;
+ Out_Name : aliased String := "*stdout" & ASCII.Nul;
+
+begin
+ -------------------------------
+ -- Initialize Standard Files --
+ -------------------------------
+
+ for J in WC_Encoding_Method loop
+ if WC_Encoding = WC_Encoding_Letters (J) then
+ Default_WCEM := J;
+ end if;
+ end loop;
+
+ -- Note: the names in these files are bogus, and probably it would be
+ -- better for these files to have no names, but the ACVC test insist!
+ -- We use names that are bound to fail in open etc.
+
+ Standard_Err.Stream := stderr;
+ Standard_Err.Name := Err_Name'Access;
+ Standard_Err.Form := Null_Str'Unrestricted_Access;
+ Standard_Err.Mode := FCB.Out_File;
+ Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
+ Standard_Err.Is_Temporary_File := False;
+ Standard_Err.Is_System_File := True;
+ Standard_Err.Is_Text_File := True;
+ Standard_Err.Access_Method := 'T';
+ Standard_Err.WC_Method := Default_WCEM;
+
+ Standard_In.Stream := stdin;
+ Standard_In.Name := In_Name'Access;
+ Standard_In.Form := Null_Str'Unrestricted_Access;
+ Standard_In.Mode := FCB.In_File;
+ Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
+ Standard_In.Is_Temporary_File := False;
+ Standard_In.Is_System_File := True;
+ Standard_In.Is_Text_File := True;
+ Standard_In.Access_Method := 'T';
+ Standard_In.WC_Method := Default_WCEM;
+
+ Standard_Out.Stream := stdout;
+ Standard_Out.Name := Out_Name'Access;
+ Standard_Out.Form := Null_Str'Unrestricted_Access;
+ Standard_Out.Mode := FCB.Out_File;
+ Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
+ Standard_Out.Is_Temporary_File := False;
+ Standard_Out.Is_System_File := True;
+ Standard_Out.Is_Text_File := True;
+ Standard_Out.Access_Method := 'T';
+ Standard_Out.WC_Method := Default_WCEM;
+
+ FIO.Chain_File (AP (Standard_In));
+ FIO.Chain_File (AP (Standard_Out));
+ FIO.Chain_File (AP (Standard_Err));
+
+ FIO.Make_Unbuffered (AP (Standard_Out));
+ FIO.Make_Unbuffered (AP (Standard_Err));
+
+end Ada.Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: the generic subpackages of Wide_Text_IO (Integer_IO, Float_IO,
+-- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private
+-- children in GNAT. These children are with'ed automatically if they are
+-- referenced, so this rearrangement is invisible to user programs, but has
+-- the advantage that only the needed parts of Wide_Text_IO are processed
+-- and loaded.
+
+with Ada.IO_Exceptions;
+with Ada.Streams;
+with System;
+with System.File_Control_Block;
+with System.WCh_Con;
+
+package Ada.Wide_Text_IO is
+
+ package WCh_Con renames System.WCh_Con;
+
+ 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)
+
+ type Count is range 0 .. Natural'Last;
+ -- The value of Count'Last must be large enough so that the assumption
+ -- enough so that the assumption that the Line, Column and Page
+ -- counts can never exceed this value is a valid assumption.
+
+ subtype Positive_Count is Count range 1 .. Count'Last;
+
+ Unbounded : constant Count := 0;
+ -- Line and page length
+
+ subtype Field is Integer range 0 .. 255;
+ -- Note: if for any reason, there is a need to increase this value,
+ -- then it will be necessary to change the corresponding value in
+ -- System.Img_Real in file s-imgrea.adb.
+
+ subtype Number_Base is Integer range 2 .. 16;
+
+ type Type_Set is (Lower_Case, Upper_Case);
+
+ ---------------------
+ -- 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;
+
+ ------------------------------------------------------
+ -- Control of default input, output and error files --
+ ------------------------------------------------------
+
+ procedure Set_Input (File : in File_Type);
+ procedure Set_Output (File : in File_Type);
+ procedure Set_Error (File : in File_Type);
+
+ function Standard_Input return File_Type;
+ function Standard_Output return File_Type;
+ function Standard_Error return File_Type;
+
+ function Current_Input return File_Type;
+ function Current_Output return File_Type;
+ function Current_Error return File_Type;
+
+ type File_Access is access constant File_Type;
+
+ function Standard_Input return File_Access;
+ function Standard_Output return File_Access;
+ function Standard_Error return File_Access;
+
+ function Current_Input return File_Access;
+ function Current_Output return File_Access;
+ function Current_Error return File_Access;
+
+ --------------------
+ -- Buffer control --
+ --------------------
+
+ -- Note: The paramter file is in out in the RM, but as pointed out
+ -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight.
+
+ procedure Flush (File : in File_Type);
+ procedure Flush;
+
+ --------------------------------------------
+ -- Specification of line and page lengths --
+ --------------------------------------------
+
+ procedure Set_Line_Length (File : in File_Type; To : in Count);
+ procedure Set_Line_Length (To : in Count);
+
+ procedure Set_Page_Length (File : in File_Type; To : in Count);
+ procedure Set_Page_Length (To : in Count);
+
+ function Line_Length (File : in File_Type) return Count;
+ function Line_Length return Count;
+
+ function Page_Length (File : in File_Type) return Count;
+ function Page_Length return Count;
+
+ ------------------------------------
+ -- Column, Line, and Page Control --
+ ------------------------------------
+
+ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1);
+ procedure New_Line (Spacing : in Positive_Count := 1);
+
+ procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1);
+ procedure Skip_Line (Spacing : in Positive_Count := 1);
+
+ function End_Of_Line (File : in File_Type) return Boolean;
+ function End_Of_Line return Boolean;
+
+ procedure New_Page (File : in File_Type);
+ procedure New_Page;
+
+ procedure Skip_Page (File : in File_Type);
+ procedure Skip_Page;
+
+ function End_Of_Page (File : in File_Type) return Boolean;
+ function End_Of_Page return Boolean;
+
+ function End_Of_File (File : in File_Type) return Boolean;
+ function End_Of_File return Boolean;
+
+ procedure Set_Col (File : in File_Type; To : in Positive_Count);
+ procedure Set_Col (To : in Positive_Count);
+
+ procedure Set_Line (File : in File_Type; To : in Positive_Count);
+ procedure Set_Line (To : in Positive_Count);
+
+ function Col (File : in File_Type) return Positive_Count;
+ function Col return Positive_Count;
+
+ function Line (File : in File_Type) return Positive_Count;
+ function Line return Positive_Count;
+
+ function Page (File : in File_Type) return Positive_Count;
+ function Page return Positive_Count;
+
+ ----------------------------
+ -- Character Input-Output --
+ ----------------------------
+
+ procedure Get (File : in File_Type; Item : out Wide_Character);
+ procedure Get (Item : out Wide_Character);
+ procedure Put (File : in File_Type; Item : in Wide_Character);
+ procedure Put (Item : in Wide_Character);
+
+ procedure Look_Ahead
+ (File : in File_Type;
+ Item : out Wide_Character;
+ End_Of_Line : out Boolean);
+
+ procedure Look_Ahead
+ (Item : out Wide_Character;
+ End_Of_Line : out Boolean);
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Wide_Character);
+
+ procedure Get_Immediate
+ (Item : out Wide_Character);
+
+ procedure Get_Immediate
+ (File : in File_Type;
+ Item : out Wide_Character;
+ Available : out Boolean);
+
+ procedure Get_Immediate
+ (Item : out Wide_Character;
+ Available : out Boolean);
+
+ -------------------------
+ -- String Input-Output --
+ -------------------------
+
+ procedure Get (File : in File_Type; Item : out Wide_String);
+ procedure Get (Item : out Wide_String);
+ procedure Put (File : in File_Type; Item : in Wide_String);
+ procedure Put (Item : in Wide_String);
+
+ procedure Get_Line
+ (File : in File_Type;
+ Item : out Wide_String;
+ Last : out Natural);
+
+ procedure Get_Line
+ (Item : out Wide_String;
+ Last : out Natural);
+
+ procedure Put_Line
+ (File : in File_Type;
+ Item : in Wide_String);
+
+ procedure Put_Line
+ (Item : in Wide_String);
+
+ ---------------------------------------
+ -- Generic packages for Input-Output --
+ ---------------------------------------
+
+ -- The generic packages:
+
+ -- Ada.Wide_Text_IO.Integer_IO
+ -- Ada.Wide_Text_IO.Modular_IO
+ -- Ada.Wide_Text_IO.Float_IO
+ -- Ada.Wide_Text_IO.Fixed_IO
+ -- Ada.Wide_Text_IO.Decimal_IO
+ -- Ada.Wide_Text_IO.Enumeration_IO
+
+ -- are implemented as separate child packages in GNAT, so the
+ -- spec and body of these packages are to be found in separate
+ -- child units. This implementation detail is hidden from the
+ -- Ada programmer by special circuitry in the compiler that
+ -- treats these child packages as though they were nested in
+ -- Text_IO. The advantage of this special processing is that
+ -- the subsidiary routines needed if these generics are used
+ -- are not loaded when they are not used.
+
+ ----------------
+ -- 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;
+ Layout_Error : exception renames IO_Exceptions.Layout_Error;
+
+private
+ -----------------------------------
+ -- Handling of Format Characters --
+ -----------------------------------
+
+ -- Line marks are represented by the single character ASCII.LF (16#0A#).
+ -- In DOS and similar systems, underlying file translation takes care
+ -- of translating this to and from the standard CR/LF sequences used in
+ -- these operating systems to mark the end of a line. On output there is
+ -- always a line mark at the end of the last line, but on input, this
+ -- line mark can be omitted, and is implied by the end of file.
+
+ -- Page marks are represented by the single character ASCII.FF (16#0C#),
+ -- The page mark at the end of the file may be omitted, and is normally
+ -- omitted on output unless an explicit New_Page call is made before
+ -- closing the file. No page mark is added when a file is appended to,
+ -- so, in accordance with the permission in (RM A.10.2(4)), there may
+ -- or may not be a page mark separating preexising text in the file
+ -- from the new text to be written.
+
+ -- A file mark is marked by the physical end of file. In DOS translation
+ -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the
+ -- physical end of file, so in effect this character is recognized as
+ -- marking the end of file in DOS and similar systems.
+
+ LM : constant := Character'Pos (ASCII.LF);
+ -- Used as line mark
+
+ PM : constant := Character'Pos (ASCII.FF);
+ -- Used as page mark, except at end of file where it is implied
+
+ -------------------------------------
+ -- Wide_Text_IO File Control Block --
+ -------------------------------------
+
+ Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8;
+ -- This gets modified during initialization (see body) using
+ -- the default value established in the call to Set_Globals.
+
+ package FCB renames System.File_Control_Block;
+
+ type Wide_Text_AFCB is new FCB.AFCB with record
+ Page : Count := 1;
+ Line : Count := 1;
+ Col : Count := 1;
+ Line_Length : Count := 0;
+ Page_Length : Count := 0;
+
+ Before_LM : Boolean := False;
+ -- This flag is used to deal with the anomolies introduced by the
+ -- peculiar definition of End_Of_File and End_Of_Page in Ada. These
+ -- functions require looking ahead more than one character. Since
+ -- there is no convenient way of backing up more than one character,
+ -- what we do is to leave ourselves positioned past the LM, but set
+ -- this flag, so that we know that from an Ada point of view we are
+ -- in front of the LM, not after it. A bit of a kludge, but it works!
+
+ Before_LM_PM : Boolean := False;
+ -- This flag similarly handles the case of being physically positioned
+ -- after a LM-PM sequence when logically we are before the LM-PM. This
+ -- flag can only be set if Before_LM is also set.
+
+ WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM;
+ -- Encoding method to be used for this file
+
+ Before_Wide_Character : Boolean := False;
+ -- This flag is set to indicate that a wide character in the input has
+ -- been read by Wide_Text_IO.Look_Ahead. If it is set to True, then it
+ -- means that the stream is logically positioned before the character
+ -- but is physically positioned after it. The character involved must
+ -- not be in the range 16#00#-16#7F#, i.e. if the flag is set, then
+ -- we know the next character has a code greater than 16#7F#, and the
+ -- value of this character is saved in Saved_Wide_Character.
+
+ Saved_Wide_Character : Wide_Character;
+ -- This field is valid only if Before_Wide_Character is set. It
+ -- contains a wide character read by Look_Ahead. If Look_Ahead
+ -- reads a character in the range 16#0000# to 16#007F#, then it
+ -- can use ungetc to put it back, but ungetc cannot be called
+ -- more than once, so for characters above this range, we don't
+ -- try to back up the file. Instead we save the character in this
+ -- field and set the flag Before_Wide_Character to indicate that
+ -- we are logically positioned before this character even though
+ -- the stream is physically positioned after it.
+
+ end record;
+
+ type File_Type is access all Wide_Text_AFCB;
+
+ function AFCB_Allocate (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr;
+
+ procedure AFCB_Close (File : access Wide_Text_AFCB);
+ procedure AFCB_Free (File : access Wide_Text_AFCB);
+
+ procedure Read
+ (File : in out Wide_Text_AFCB;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset);
+ -- Read operation used when Wide_Text_IO file is treated as a Stream
+
+ procedure Write
+ (File : in out Wide_Text_AFCB;
+ Item : in Ada.Streams.Stream_Element_Array);
+ -- Write operation used when Wide_Text_IO file is treated as a Stream
+
+ ------------------------
+ -- The Standard Files --
+ ------------------------
+
+ Null_Str : aliased constant String := "";
+ -- Used as name and form of standard files
+
+ Standard_Err_AFCB : aliased Wide_Text_AFCB;
+ Standard_In_AFCB : aliased Wide_Text_AFCB;
+ Standard_Out_AFCB : aliased Wide_Text_AFCB;
+
+ Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
+ Standard_In : aliased File_Type := Standard_In_AFCB'Access;
+ Standard_Out : aliased File_Type := Standard_Out_AFCB'Access;
+ -- Standard files
+
+ Current_In : aliased File_Type := Standard_In;
+ Current_Out : aliased File_Type := Standard_Out;
+ Current_Err : aliased File_Type := Standard_Err;
+ -- Current files
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- These subprograms are in the private part of the spec so that they can
+ -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO.
+
+ -- Note: we use Integer in these declarations instead of the more accurate
+ -- Interfaces.C_Streams.int, because we do not want to drag in the spec of
+ -- this interfaces package with the spec of Ada.Text_IO, and we know that
+ -- in fact these types are identical
+
+ function Getc (File : File_Type) return Integer;
+ -- Gets next character from file, which has already been checked for
+ -- being in read status, and returns the character read if no error
+ -- occurs. The result is EOF if the end of file was read.
+
+ procedure Get_Character
+ (File : in File_Type;
+ Item : out Character);
+ -- This is essentially a copy of the normal Get routine from Text_IO. It
+ -- obtains a single character from the input file File, and places it in
+ -- Item. This character may be the leading character of a Wide_Character
+ -- sequence, but that is up to the caller to deal with.
+
+ function Get_Wide_Char
+ (C : Character;
+ File : File_Type)
+ return Wide_Character;
+ -- This function is shared by Get and Get_Immediate to extract a wide
+ -- character value from the given File. The first byte has already been
+ -- read and is passed in C. The wide character value is returned as the
+ -- result, and the file pointer is bumped past the character.
+
+ function Nextc (File : File_Type) return Integer;
+ -- Returns next character from file without skipping past it (i.e. it
+ -- is a combination of Getc followed by an Ungetc).
+
+ procedure Putc (ch : Integer; File : File_Type);
+ -- Outputs the given character to the file, which has already been
+ -- checked for being in output status. Device_Error is raised if the
+ -- character cannot be written.
+
+ procedure Terminate_Line (File : File_Type);
+ -- If the file is in Write_File or Append_File mode, and the current
+ -- line is not terminated, then a line terminator is written using
+ -- New_Line. Note that there is no Terminate_Page routine, because
+ -- the page mark at the end of the file is implied if necessary.
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- and end of file character (EOF) is ignored.
+
+end Ada.Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Text_IO.Float_Aux;
+
+with System.Img_Real; use System.Img_Real;
+
+package body Ada.Wide_Text_IO.Complex_Aux is
+
+ package Aux renames Ada.Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer;
+ Paren : Boolean := False;
+
+ begin
+ -- General note for following code, exceptions from the calls
+ -- to Get for components of the complex value are propagated.
+
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr);
+
+ for J in Ptr + 1 .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+
+ -- Case of width = 0
+
+ else
+ Load_Skip (File);
+ Ptr := 0;
+ Load (File, Buf, Ptr, '(', Paren);
+ Aux.Get (File, ItemR, 0);
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ',');
+ Aux.Get (File, ItemI, 0);
+
+ if Paren then
+ Load_Skip (File);
+ Load (File, Buf, Ptr, ')', Paren);
+
+ if not Paren then
+ raise Data_Error;
+ end if;
+ end if;
+ end if;
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : in String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Paren : Boolean;
+ Pos : Integer;
+
+ begin
+ String_Skip (From, Pos);
+
+ if From (Pos) = '(' then
+ Pos := Pos + 1;
+ Paren := True;
+ else
+ Paren := False;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemR, Pos);
+
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) = ',' then
+ Pos := Pos + 1;
+ end if;
+
+ Aux.Gets (From (Pos .. From'Last), ItemI, Pos);
+
+ if Paren then
+ String_Skip (From (Pos + 1 .. From'Last), Pos);
+
+ if From (Pos) /= ')' then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Last := Pos;
+ end Gets;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field)
+ is
+ begin
+ Put (File, '(');
+ Aux.Put (File, ItemR, Fore, Aft, Exp);
+ Put (File, ',');
+ Aux.Put (File, ItemI, Fore, Aft, Exp);
+ Put (File, ')');
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ I_String : String (1 .. 3 * Field'Last);
+ R_String : String (1 .. 3 * Field'Last);
+
+ Iptr : Natural;
+ Rptr : Natural;
+
+ begin
+ -- Both parts are initially converted with a Fore of 0
+
+ Rptr := 0;
+ Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp);
+ Iptr := 0;
+ Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
+
+ -- Check room for both parts plus parens plus comma (RM G.1.3(34))
+
+ if Rptr + Iptr + 3 > To'Length then
+ raise Layout_Error;
+ end if;
+
+ -- If there is room, layout result according to (RM G.1.3(31-33))
+
+ To (To'First) := '(';
+ To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr);
+ To (To'First + Rptr + 1) := ',';
+
+ To (To'Last) := ')';
+
+
+ To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr);
+
+ for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop
+ To (J) := ' ';
+ end loop;
+ end Puts;
+
+end Ada.Wide_Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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 contains the routines for Ada.Wide_Text_IO.Complex_IO that
+-- are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Complex_IO itself,
+-- except that the generic parameter Complex has been replaced by separate
+-- real and imaginary values of type Long_Long_Float, and default parameters
+-- have been removed because they are supplied explicitly by the calls from
+-- within the generic template.
+
+package Ada.Wide_Text_IO.Complex_Aux is
+
+ procedure Get
+ (File : in File_Type;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Width : Field);
+
+ procedure Gets
+ (From : String;
+ ItemR : out Long_Long_Float;
+ ItemI : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Put
+ (File : File_Type;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field);
+
+ procedure Puts
+ (To : out String;
+ ItemR : Long_Long_Float;
+ ItemI : Long_Long_Float;
+ Aft : Field;
+ Exp : Field);
+
+end Ada.Wide_Text_IO.Complex_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Wide_Text_IO.Complex_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+with Ada.Unchecked_Conversion;
+
+package body Ada.Wide_Text_IO.Complex_IO is
+
+ package Aux renames Ada.Wide_Text_IO.Complex_Aux;
+
+ subtype LLF is Long_Long_Float;
+ -- Type used for calls to routines in Aux
+
+-- subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ function TFT is new
+ Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type);
+ -- This unchecked conversion is to get around a visibility bug in
+ -- GNAT version 2.04w. It should be possible to simply use the
+ -- subtype declared above and do normal checked conversions.
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Complex;
+ Width : in Field := 0)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ begin
+ Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (Item : out Complex;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Complex;
+ Last : out Positive)
+ is
+ Real_Item : Real'Base;
+ Imag_Item : Real'Base;
+
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last);
+ Item := (Real_Item, Imag_Item);
+
+ exception
+ when Data_Error => raise Constraint_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Complex;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ IO . C O M P L E X _ 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.Numerics.Generic_Complex_Types;
+
+generic
+ with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>);
+
+package Ada.Wide_Text_IO.Complex_IO is
+
+ use Complex_Types;
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Real'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Complex;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Complex;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Complex;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Complex;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+end Ada.Wide_Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X 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 Unchecked_Conversion;
+
+package body Ada.Wide_Text_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 : Wide_Text_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => To_FCB (Mode),
+ Name => "",
+ Form => Form,
+ Amethod => 'W',
+ Creat => False,
+ Text => True,
+ C_Stream => C_Stream);
+
+ end Open;
+
+end Ada.Wide_Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . C _ S T R E A M S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Wide_Text_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.Wide_Text_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.Wide_Text_IO.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux;
+
+with System.Img_Dec; use System.Img_Dec;
+with System.Img_LLD; use System.Img_LLD;
+with System.Val_Dec; use System.Val_Dec;
+with System.Val_LLD; use System.Val_LLD;
+
+package body Ada.Wide_Text_IO.Decimal_Aux is
+
+ -------------
+ -- Get_Dec --
+ -------------
+
+ function Get_Dec
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer)
+ return Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_Dec;
+
+ -------------
+ -- Get_LLD --
+ -------------
+
+ function Get_LLD
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer)
+ return Long_Long_Integer
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer;
+ Stop : Integer := 0;
+ Item : Long_Long_Integer;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ Ptr := 1;
+ end if;
+
+ Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ return Item;
+ end Get_LLD;
+
+ --------------
+ -- Gets_Dec --
+ --------------
+
+ function Gets_Dec
+ (From : String;
+ Last : access Positive;
+ Scale : Integer)
+ return Integer
+ is
+ Pos : aliased Integer;
+ Item : Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+
+ end Gets_Dec;
+
+ --------------
+ -- Gets_LLD --
+ --------------
+
+ function Gets_LLD
+ (From : String;
+ Last : access Positive;
+ Scale : Integer)
+ return Long_Long_Integer
+ is
+ Pos : aliased Integer;
+ Item : Long_Long_Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
+ Last.all := Pos - 1;
+ return Item;
+
+ exception
+ when Constraint_Error =>
+ Last.all := Pos - 1;
+ raise Data_Error;
+
+ end Gets_LLD;
+
+ -------------
+ -- Put_Dec --
+ -------------
+
+ procedure Put_Dec
+ (File : File_Type;
+ Item : Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Dec;
+
+ -------------
+ -- Put_LLD --
+ -------------
+
+ procedure Put_LLD
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLD;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_Dec;
+
+ --------------
+ -- Puts_Dec --
+ --------------
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : Long_Long_Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer)
+ is
+ Buf : String (1 .. Field'Last);
+ Fore : Integer;
+ Ptr : Natural := 0;
+
+ begin
+ if Exp = 0 then
+ Fore := To'Length - 1 - Aft;
+ else
+ Fore := To'Length - 2 - Aft - Exp;
+ end if;
+
+ if Fore < 1 then
+ raise Layout_Error;
+ end if;
+
+ Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLD;
+
+end Ada.Wide_Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO
+-- that are shared among separate instantiations of this package. The
+-- routines in the package are identical semantically to those declared
+-- in Wide_Text_IO, except that default values have been supplied by the
+-- generic, and the Num parameter has been replaced by Integer or
+-- Long_Long_Integer, with an additional Scale parameter giving the
+-- value of Num'Scale. In addition the Get routines return the value
+-- rather than store it in an Out parameter.
+
+private package Ada.Wide_Text_IO.Decimal_Aux is
+
+ function Get_Dec
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer)
+ return Integer;
+
+ function Get_LLD
+ (File : File_Type;
+ Width : Field;
+ Scale : Integer)
+ return Long_Long_Integer;
+
+ function Gets_Dec
+ (From : String;
+ Last : access Positive;
+ Scale : Integer)
+ return Integer;
+
+ function Gets_LLD
+ (From : String;
+ Last : access Positive;
+ Scale : Integer)
+ return Long_Long_Integer;
+
+ procedure Put_Dec
+ (File : File_Type;
+ Item : Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Put_LLD
+ (File : File_Type;
+ Item : Long_Long_Integer;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Puts_Dec
+ (To : out String;
+ Item : Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+ procedure Puts_LLD
+ (To : out String;
+ Item : Long_Long_Integer;
+ Aft : Field;
+ Exp : Field;
+ Scale : Integer);
+
+end Ada.Wide_Text_IO.Decimal_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Decimal_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Decimal_IO is
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Text_IO.Decimal_Aux;
+
+ Scale : constant Integer := Num'Scale;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Item := Num (Aux.Get_LLD (TFT (File), Width, Scale));
+ -- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale));
+ -- above is what we should write, but gets assert error ???
+
+ else
+ Item := Num (Aux.Get_Dec (TFT (File), Width, Scale));
+ -- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale));
+ -- above is what we should write, but gets assert error ???
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Num'Size > Integer'Size then
+ -- Item := Num'Fixed_Value
+ -- should write above, but gets assert error ???
+ Item := Num
+ (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale));
+ else
+ -- Item := Num'Fixed_Value
+ -- should write above, but gets assert error ???
+ Item := Num
+ (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale));
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ if Num'Size > Integer'Size then
+ Aux.Put_LLD
+-- (TFT (File), Long_Long_Integer'Integer_Value (Item),
+-- ???
+ (TFT (File), Long_Long_Integer (Item),
+ Fore, Aft, Exp, Scale);
+ else
+ Aux.Put_Dec
+-- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale);
+-- ???
+ (TFT (File), Integer (Item), Fore, Aft, Exp, Scale);
+
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Num'Size > Integer'Size then
+-- Aux.Puts_LLD
+-- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale);
+-- ???
+ Aux.Puts_LLD
+ (S, Long_Long_Integer (Item), Aft, Exp, Scale);
+ else
+-- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale);
+-- ???
+ Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Decimal_IO is a subpackage of
+-- Wide_Text_IO. In GNAT we make it a child package to avoid loading the
+-- necessary code if Decimal_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <> digits <>;
+
+package Ada.Wide_Text_IO.Decimal_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+end Ada.Wide_Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E D I T I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- 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.Strings.Fixed;
+with Ada.Strings.Wide_Fixed;
+
+package body Ada.Wide_Text_IO.Editing is
+
+ package Strings renames Ada.Strings;
+ package Strings_Fixed renames Ada.Strings.Fixed;
+ package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed;
+ package Wide_Text_IO renames Ada.Wide_Text_IO;
+
+ -----------------------
+ -- Local_Subprograms --
+ -----------------------
+
+ function To_Wide (C : Character) return Wide_Character;
+ pragma Inline (To_Wide);
+ -- Convert Character to corresponding Wide_Character
+
+ ---------------------
+ -- Blank_When_Zero --
+ ---------------------
+
+ function Blank_When_Zero (Pic : in Picture) return Boolean is
+ begin
+ return Pic.Contents.Original_BWZ;
+ end Blank_When_Zero;
+
+ --------------------
+ -- Decimal_Output --
+ --------------------
+
+ package body Decimal_Output is
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image
+ (Item : in Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark)
+ return Wide_String
+ is
+ begin
+ return Format_Number
+ (Pic.Contents, Num'Image (Item),
+ Currency, Fill, Separator, Radix_Mark);
+ end Image;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length
+ (Pic : in Picture;
+ Currency : in Wide_String := Default_Currency)
+ return Natural
+ is
+ Picstr : constant String := Pic_String (Pic);
+ V_Adjust : Integer := 0;
+ Cur_Adjust : Integer := 0;
+
+ begin
+ -- Check if Picstr has 'V' or '$'
+
+ -- If 'V', then length is 1 less than otherwise
+
+ -- If '$', then length is Currency'Length-1 more than otherwise
+
+ -- This should use the string handling package ???
+
+ for J in Picstr'Range loop
+ if Picstr (J) = 'V' then
+ V_Adjust := -1;
+
+ elsif Picstr (J) = '$' then
+ Cur_Adjust := Currency'Length - 1;
+ end if;
+ end loop;
+
+ return Picstr'Length - V_Adjust + Cur_Adjust;
+ end Length;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in Wide_Text_IO.File_Type;
+ Item : in Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark)
+ is
+ begin
+ Wide_Text_IO.Put (File, Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark)
+ is
+ begin
+ Wide_Text_IO.Put (Image (Item, Pic,
+ Currency, Fill, Separator, Radix_Mark));
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark)
+ is
+ Result : constant Wide_String :=
+ Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
+
+ begin
+ if Result'Length > To'Length then
+ raise Wide_Text_IO.Layout_Error;
+ else
+ Strings_Wide_Fixed.Move (Source => Result, Target => To,
+ Justify => Strings.Right);
+ end if;
+ end Put;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency)
+ return Boolean
+ is
+ begin
+ declare
+ Temp : constant Wide_String := Image (Item, Pic, Currency);
+ pragma Warnings (Off, Temp);
+
+ begin
+ return True;
+ end;
+
+ exception
+ when Layout_Error => return False;
+
+ end Valid;
+
+ end Decimal_Output;
+
+ ------------
+ -- Expand --
+ ------------
+
+ function Expand (Picture : in String) return String is
+ Result : String (1 .. MAX_PICSIZE);
+ Picture_Index : Integer := Picture'First;
+ Result_Index : Integer := Result'First;
+ Count : Natural;
+ Last : Integer;
+
+ begin
+ if Picture'Length < 1 then
+ raise Picture_Error;
+ end if;
+
+ if Picture (Picture'First) = '(' then
+ raise Picture_Error;
+ end if;
+
+ loop
+ case Picture (Picture_Index) is
+
+ when '(' =>
+
+ -- We now need to scan out the count after a left paren.
+ -- In the non-wide version we used Integer_IO.Get, but
+ -- that is not convenient here, since we don't want to
+ -- drag in normal Text_IO just for this purpose. So we
+ -- do the scan ourselves, with the normal validity checks.
+
+ Last := Picture_Index + 1;
+ Count := 0;
+
+ if Picture (Last) not in '0' .. '9' then
+ raise Picture_Error;
+ end if;
+
+ Count := Character'Pos (Picture (Last)) - Character'Pos ('0');
+ Last := Last + 1;
+
+ loop
+ if Last > Picture'Last then
+ raise Picture_Error;
+ end if;
+
+ if Picture (Last) = '_' then
+ if Picture (Last - 1) = '_' then
+ raise Picture_Error;
+ end if;
+
+ elsif Picture (Last) = ')' then
+ exit;
+
+ elsif Picture (Last) not in '0' .. '9' then
+ raise Picture_Error;
+
+ else
+ Count := Count * 10
+ + Character'Pos (Picture (Last)) -
+ Character'Pos ('0');
+ end if;
+
+ Last := Last + 1;
+ end loop;
+
+ -- In what follows note that one copy of the repeated
+ -- character has already been made, so a count of one is a
+ -- no-op, and a count of zero erases a character.
+
+ for J in 2 .. Count loop
+ Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
+ end loop;
+
+ Result_Index := Result_Index + Count - 1;
+
+ -- Last was a ')' throw it away too.
+
+ Picture_Index := Last + 1;
+
+ when ')' =>
+ raise Picture_Error;
+
+ when others =>
+ Result (Result_Index) := Picture (Picture_Index);
+ Picture_Index := Picture_Index + 1;
+ Result_Index := Result_Index + 1;
+
+ end case;
+
+ exit when Picture_Index > Picture'Last;
+ end loop;
+
+ return Result (1 .. Result_Index - 1);
+
+ exception
+ when others =>
+ raise Picture_Error;
+
+ end Expand;
+
+ -------------------
+ -- Format_Number --
+ -------------------
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : Wide_String;
+ Fill_Character : Wide_Character;
+ Separator_Character : Wide_Character;
+ Radix_Point : Wide_Character)
+ return Wide_String
+ is
+ Attrs : Number_Attributes := Parse_Number_String (Number);
+ Position : Integer;
+ Rounded : String := Number;
+
+ Sign_Position : Integer := Pic.Sign_Position; -- may float.
+
+ Answer : Wide_String (1 .. Pic.Picture.Length);
+ Last : Integer;
+ Currency_Pos : Integer := Pic.Start_Currency;
+
+ Dollar : Boolean := False;
+ -- Overridden immediately if necessary.
+
+ Zero : Boolean := True;
+ -- Set to False when a non-zero digit is output.
+
+ begin
+
+ -- If the picture has fewer decimal places than the number, the image
+ -- must be rounded according to the usual rules.
+
+ if Attrs.Has_Fraction then
+ declare
+ R : constant Integer :=
+ (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
+ - Pic.Max_Trailing_Digits;
+ R_Pos : Integer;
+
+ begin
+ if R > 0 then
+ R_Pos := Rounded'Length - R;
+
+ if Rounded (R_Pos + 1) > '4' then
+
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+
+ while R_Pos > 1 loop
+ if Rounded (R_Pos) = '.' then
+ R_Pos := R_Pos - 1;
+ end if;
+
+ if Rounded (R_Pos) /= '9' then
+ Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
+ exit;
+ else
+ Rounded (R_Pos) := '0';
+ R_Pos := R_Pos - 1;
+ end if;
+ end loop;
+
+ -- The rounding may add a digit in front. Either the
+ -- leading blank or the sign (already captured) can
+ -- be overwritten.
+
+ if R_Pos = 1 then
+ Rounded (R_Pos) := '1';
+ Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ for J in Answer'Range loop
+ Answer (J) := To_Wide (Pic.Picture.Expanded (J));
+ end loop;
+
+ if Pic.Start_Currency /= Invalid_Position then
+ Dollar := Answer (Pic.Start_Currency) = '$';
+ end if;
+
+ -- Fix up "direct inserts" outside the playing field. Set up as one
+ -- loop to do the beginning, one (reverse) loop to do the end.
+
+ Last := 1;
+ loop
+ exit when Last = Pic.Start_Float;
+ exit when Last = Pic.Radix_Position;
+ exit when Answer (Last) = '9';
+
+ case Answer (Last) is
+
+ when '_' =>
+ Answer (Last) := Separator_Character;
+
+ when 'b' =>
+ Answer (Last) := ' ';
+
+ when others =>
+ null;
+
+ end case;
+
+ exit when Last = Answer'Last;
+
+ Last := Last + 1;
+ end loop;
+
+ -- Now for the end...
+
+ for J in reverse Last .. Answer'Last loop
+ exit when J = Pic.Radix_Position;
+
+ -- Do this test First, Separator_Character can equal Pic.Floater.
+
+ if Answer (J) = Pic.Floater then
+ exit;
+ end if;
+
+ case Answer (J) is
+
+ when '_' =>
+ Answer (J) := Separator_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ exit;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ -- Non-floating sign
+
+ if Pic.Start_Currency /= -1
+ and then Answer (Pic.Start_Currency) = '#'
+ and then Pic.Floater /= '#'
+ then
+ if Currency_Symbol'Length >
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ raise Picture_Error;
+
+ elsif Currency_Symbol'Length =
+ Pic.End_Currency - Pic.Start_Currency + 1
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ Currency_Symbol;
+
+ elsif Pic.Radix_Position = Invalid_Position
+ or else Pic.Start_Currency < Pic.Radix_Position
+ then
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
+ Pic.End_Currency) := Currency_Symbol;
+
+ else
+ Answer (Pic.Start_Currency .. Pic.End_Currency) :=
+ (others => ' ');
+ Answer (Pic.Start_Currency ..
+ Pic.Start_Currency + Currency_Symbol'Length - 1) :=
+ Currency_Symbol;
+ end if;
+ end if;
+
+ -- Fill in leading digits
+
+ if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
+ Pic.Max_Leading_Digits
+ then
+ raise Layout_Error;
+ end if;
+
+ if Pic.Radix_Position = Invalid_Position then
+ Position := Answer'Last;
+ else
+ Position := Pic.Radix_Position - 1;
+ end if;
+
+ for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
+
+ while Answer (Position) /= '9'
+ and Answer (Position) /= Pic.Floater
+ loop
+ if Answer (Position) = '_' then
+ Answer (Position) := Separator_Character;
+
+ elsif Answer (Position) = 'b' then
+ Answer (Position) := ' ';
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ Answer (Position) := To_Wide (Rounded (J));
+
+ if Rounded (J) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position - 1;
+ end loop;
+
+ -- Do lead float
+
+ if Pic.Start_Float = Invalid_Position then
+
+ -- No leading floats, but need to change '9' to '0', '_' to
+ -- Separator_Character and 'b' to ' '.
+
+ for J in Last .. Position loop
+
+ -- Last set when fixing the "uninteresting" leaders above.
+ -- Don't duplicate the work.
+
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+
+ end loop;
+
+ elsif Pic.Floater = '<'
+ or else
+ Pic.Floater = '+'
+ or else
+ Pic.Floater = '-'
+ then
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Sign_Position := Position;
+
+ elsif Pic.Floater = '$' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := ' '; -- no separator before leftmost digit.
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position - 1 loop
+ Answer (J) := ' ';
+ end loop;
+
+ Answer (Position) := Pic.Floater;
+ Currency_Pos := Position;
+
+ elsif Pic.Floater = '*' then
+
+ for J in Pic.End_Float .. Position loop -- May be null range.
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := '*';
+ end if;
+ end loop;
+
+ if Position > Pic.End_Float then
+ Position := Pic.End_Float;
+ end if;
+
+ for J in Pic.Start_Float .. Position loop
+ Answer (J) := '*';
+ end loop;
+
+ else
+ if Pic.Floater = '#' then
+ Currency_Pos := Currency_Symbol'Length;
+ end if;
+
+ for J in reverse Pic.Start_Float .. Position loop
+ case Answer (J) is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' | '/' | '0' =>
+ Answer (J) := ' ';
+
+ when '9' =>
+ Answer (J) := '0';
+
+ when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
+ null;
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos = 0 then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+ end if;
+
+ -- Do sign
+
+ if Sign_Position = Invalid_Position then
+ if Attrs.Negative then
+ raise Layout_Error;
+ end if;
+
+ else
+ if Attrs.Negative then
+ case Answer (Sign_Position) is
+ when 'C' | 'D' | '-' =>
+ null;
+
+ when '+' =>
+ Answer (Sign_Position) := '-';
+
+ when '<' =>
+ Answer (Sign_Position) := '(';
+ Answer (Pic.Second_Sign) := ')';
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ else -- positive
+
+ case Answer (Sign_Position) is
+
+ when '-' =>
+ Answer (Sign_Position) := ' ';
+
+ when '<' | 'C' | 'D' =>
+ Answer (Sign_Position) := ' ';
+ Answer (Pic.Second_Sign) := ' ';
+
+ when '+' =>
+ null;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end if;
+ end if;
+
+ -- Fill in trailing digits
+
+ if Pic.Max_Trailing_Digits > 0 then
+
+ if Attrs.Has_Fraction then
+ Position := Attrs.Start_Of_Fraction;
+ Last := Pic.Radix_Position + 1;
+
+ for J in Last .. Answer'Last loop
+
+ if Answer (J) = '9' or Answer (J) = Pic.Floater then
+ Answer (J) := To_Wide (Rounded (Position));
+
+ if Rounded (Position) /= '0' then
+ Zero := False;
+ end if;
+
+ Position := Position + 1;
+ Last := J + 1;
+
+ -- Used up fraction but remember place in Answer
+
+ exit when Position > Attrs.End_Of_Fraction;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ end if;
+
+ Last := J + 1;
+ end loop;
+
+ Position := Last;
+
+ else
+ Position := Pic.Radix_Position + 1;
+ end if;
+
+ -- Now fill remaining 9's with zeros and _ with separators
+
+ Last := Answer'Last;
+
+ for J in Position .. Last loop
+ if Answer (J) = '9' then
+ Answer (J) := '0';
+
+ elsif Answer (J) = Pic.Floater then
+ Answer (J) := '0';
+
+ elsif Answer (J) = '_' then
+ Answer (J) := Separator_Character;
+
+ elsif Answer (J) = 'b' then
+ Answer (J) := ' ';
+
+ end if;
+ end loop;
+
+ Position := Last + 1;
+
+ else
+ if Pic.Floater = '#' and then Currency_Pos /= 0 then
+ raise Layout_Error;
+ end if;
+
+ -- No trailing digits, but now J may need to stick in a currency
+ -- symbol or sign.
+
+ if Pic.Start_Currency = Invalid_Position then
+ Position := Answer'Last + 1;
+ else
+ Position := Pic.Start_Currency;
+ end if;
+ end if;
+
+ for J in Position .. Answer'Last loop
+
+ if Pic.Start_Currency /= Invalid_Position and then
+ Answer (Pic.Start_Currency) = '#' then
+ Currency_Pos := 1;
+ end if;
+
+ -- Note: There are some weird cases J can imagine with 'b' or '#'
+ -- in currency strings where the following code will cause
+ -- glitches. The trick is to tell when the character in the
+ -- answer should be checked, and when to look at the original
+ -- string. Some other time. RIE 11/26/96 ???
+
+ case Answer (J) is
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'b' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when '_' =>
+
+ case Pic.Floater is
+
+ when '*' =>
+ Answer (J) := Fill_Character;
+
+ when 'Z' | 'z' =>
+ Answer (J) := ' ';
+
+ when '#' =>
+ if Currency_Pos > Currency_Symbol'Length then
+ Answer (J) := ' ';
+ else
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ when others =>
+ exit;
+
+ end case;
+ end loop;
+
+ -- Now get rid of Blank_when_Zero and complete Star fill.
+
+ if Zero and Pic.Blank_When_Zero then
+
+ -- Value is zero, and blank it.
+
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position and then
+ Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+ end if;
+
+ return Wide_String'(1 .. Last => ' ');
+
+ elsif Zero and Pic.Star_Fill then
+ Last := Answer'Last;
+
+ if Dollar then
+ Last := Last - 1 + Currency_Symbol'Length;
+ end if;
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = 'V' then
+ Last := Last - 1;
+
+ elsif Dollar then
+ if Pic.Radix_Position > Pic.Start_Currency then
+ return Wide_String' (1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ Wide_String' (Pic.Radix_Position + 1 .. Last => '*');
+
+ else
+ return
+ Wide_String'
+ (1 ..
+ Pic.Radix_Position + Currency_Symbol'Length - 2
+ => '*') &
+ Radix_Point &
+ Wide_String'
+ (Pic.Radix_Position + Currency_Symbol'Length .. Last
+ => '*');
+ end if;
+
+ else
+ return
+ Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
+ Radix_Point &
+ Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
+ end if;
+ end if;
+
+ return Wide_String' (1 .. Last => '*');
+ end if;
+
+ -- This was once a simple return statement, now there are nine
+ -- different return cases. Not to mention the five above to deal
+ -- with zeros. Why not split things out?
+
+ -- Processing the radix and sign expansion separately
+ -- would require lots of copying--the string and some of its
+ -- indicies--without really simplifying the logic. The cases are:
+
+ -- 1) Expand $, replace '.' with Radix_Point
+ -- 2) No currency expansion, replace '.' with Radix_Point
+ -- 3) Expand $, radix blanked
+ -- 4) No currency expansion, radix blanked
+ -- 5) Elide V
+ -- 6) Expand $, Elide V
+ -- 7) Elide V, Expand $ (Two cases depending on order.)
+ -- 8) No radix, expand $
+ -- 9) No radix, no currency expansion
+
+ if Pic.Radix_Position /= Invalid_Position then
+
+ if Answer (Pic.Radix_Position) = '.' then
+ Answer (Pic.Radix_Position) := Radix_Point;
+
+ if Dollar then
+
+ -- 1) Expand $, replace '.' with Radix_Point
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 2) No currency expansion, replace '.' with Radix_Point
+
+ return Answer;
+ end if;
+
+ elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix.
+ if Dollar then
+
+ -- 3) Expand $, radix blanked
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 4) No expansion, radix blanked
+
+ return Answer;
+ end if;
+
+ -- V cases
+
+ else
+ if not Dollar then
+
+ -- 5) Elide V
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ elsif Currency_Pos < Pic.Radix_Position then
+
+ -- 6) Expand $, Elide V
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Answer'Last);
+
+ else
+ -- 7) Elide V, Expand $
+
+ return Answer (1 .. Pic.Radix_Position - 1) &
+ Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
+ Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+ end if;
+ end if;
+
+ elsif Dollar then
+
+ -- 8) No radix, expand $
+
+ return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
+ Answer (Currency_Pos + 1 .. Answer'Last);
+
+ else
+ -- 9) No radix, no currency expansion
+
+ return Answer;
+ end if;
+
+ end Format_Number;
+
+ -------------------------
+ -- Parse_Number_String --
+ -------------------------
+
+ function Parse_Number_String (Str : String) return Number_Attributes is
+ Answer : Number_Attributes;
+
+ begin
+ for J in Str'Range loop
+ case Str (J) is
+
+ when ' ' =>
+ null; -- ignore
+
+ when '1' .. '9' =>
+
+ -- Decide if this is the start of a number.
+ -- If so, figure out which one...
+
+ if Answer.Has_Fraction then
+ Answer.End_Of_Fraction := J;
+ else
+ if Answer.Start_Of_Int = Invalid_Position then
+ -- start integer
+ Answer.Start_Of_Int := J;
+ end if;
+ Answer.End_Of_Int := J;
+ end if;
+
+ when '0' =>
+
+ -- Only count a zero before the decimal point if it follows a
+ -- non-zero digit. After the decimal point, zeros will be
+ -- counted if followed by a non-zero digit.
+
+ if not Answer.Has_Fraction then
+ if Answer.Start_Of_Int /= Invalid_Position then
+ Answer.End_Of_Int := J;
+ end if;
+ end if;
+
+ when '-' =>
+
+ -- Set negative
+
+ Answer.Negative := True;
+
+ when '.' =>
+
+ -- Close integer, start fraction
+
+ if Answer.Has_Fraction then
+ raise Picture_Error;
+ end if;
+
+ -- Two decimal points is a no-no.
+
+ Answer.Has_Fraction := True;
+ Answer.End_Of_Fraction := J;
+
+ -- Could leave this at Invalid_Position, but this seems the
+ -- right way to indicate a null range...
+
+ Answer.Start_Of_Fraction := J + 1;
+ Answer.End_Of_Int := J - 1;
+
+ when others =>
+ raise Picture_Error; -- can this happen? probably not!
+ end case;
+ end loop;
+
+ if Answer.Start_Of_Int = Invalid_Position then
+ Answer.Start_Of_Int := Answer.End_Of_Int + 1;
+ end if;
+
+ -- No significant (intger) digits needs a null range.
+
+ return Answer;
+
+ end Parse_Number_String;
+
+ ----------------
+ -- Pic_String --
+ ----------------
+
+ -- The following ensures that we return B and not b being careful not
+ -- to break things which expect lower case b for blank. See CXF3A02.
+
+ function Pic_String (Pic : in Picture) return String is
+ Temp : String (1 .. Pic.Contents.Picture.Length) :=
+ Pic.Contents.Picture.Expanded;
+ begin
+ for J in Temp'Range loop
+ if Temp (J) = 'b' then Temp (J) := 'B'; end if;
+ end loop;
+
+ return Temp;
+ end Pic_String;
+
+ ------------------
+ -- Precalculate --
+ ------------------
+
+ procedure Precalculate (Pic : in out Format_Record) is
+
+ Computed_BWZ : Boolean := True;
+
+ type Legality is (Okay, Reject);
+ State : Legality := Reject;
+ -- Start in reject, which will reject null strings.
+
+ Index : Pic_Index := Pic.Picture.Expanded'First;
+
+ function At_End return Boolean;
+ pragma Inline (At_End);
+
+ procedure Set_State (L : Legality);
+ pragma Inline (Set_State);
+
+ function Look return Character;
+ pragma Inline (Look);
+
+ function Is_Insert return Boolean;
+ pragma Inline (Is_Insert);
+
+ procedure Skip;
+ pragma Inline (Skip);
+
+ procedure Trailing_Currency;
+ procedure Trailing_Bracket;
+ procedure Number_Fraction;
+ procedure Number_Completion;
+ procedure Number_Fraction_Or_Bracket;
+ procedure Number_Fraction_Or_Z_Fill;
+ procedure Zero_Suppression;
+ procedure Floating_Bracket;
+ procedure Number_Fraction_Or_Star_Fill;
+ procedure Star_Suppression;
+ procedure Number_Fraction_Or_Dollar;
+ procedure Leading_Dollar;
+ procedure Number_Fraction_Or_Pound;
+ procedure Leading_Pound;
+ procedure Picture;
+ procedure Floating_Plus;
+ procedure Floating_Minus;
+ procedure Picture_Plus;
+ procedure Picture_Minus;
+ procedure Picture_Bracket;
+ procedure Number;
+ procedure Optional_RHS_Sign;
+ procedure Picture_String;
+
+ ------------
+ -- At_End --
+ ------------
+
+ function At_End return Boolean is
+ begin
+ return Index > Pic.Picture.Length;
+ end At_End;
+
+ ----------------------
+ -- Floating_Bracket --
+ ----------------------
+
+ -- Note that Floating_Bracket is only called with an acceptable
+ -- prefix. But we don't set Okay, because we must end with a '>'.
+
+ procedure Floating_Bracket is
+ begin
+ Pic.Floater := '<';
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+
+ -- First bracket wasn't counted...
+
+ Skip; -- known '<'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+
+ when '$' =>
+ Leading_Dollar;
+
+ when '#' =>
+ Leading_Pound;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Bracket;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Bracket;
+
+ --------------------
+ -- Floating_Minus --
+ --------------------
+
+ procedure Floating_Minus is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '-' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '-' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Floating_Minus;
+
+ -------------------
+ -- Floating_Plus --
+ -------------------
+
+ procedure Floating_Plus is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '9' =>
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip; -- Radix
+
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ if At_End then
+ return;
+ end if;
+
+ if Look = '+' then
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ else
+ Number_Completion;
+ end if;
+
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Floating_Plus;
+
+ ---------------
+ -- Is_Insert --
+ ---------------
+
+ function Is_Insert return Boolean is
+ begin
+ if At_End then
+ return False;
+ end if;
+
+ case Pic.Picture.Expanded (Index) is
+
+ when '_' | '0' | '/' => return True;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b'; -- canonical
+ return True;
+
+ when others => return False;
+ end case;
+ end Is_Insert;
+
+ --------------------
+ -- Leading_Dollar --
+ --------------------
+
+ -- Note that Leading_Dollar can be called in either State.
+ -- It will set state to Okay only if a 9 or (second) $
+ -- is encountered.
+
+ -- Also notice the tricky bit with State and Zero_Suppression.
+ -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
+ -- encountered, exactly the cases where State has been set.
+
+ procedure Leading_Dollar is
+ begin
+ -- Treat as a floating dollar, and unwind otherwise.
+
+ Pic.Floater := '$';
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Skip; -- known '$'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ -- A trailing insertion character is not part of the
+ -- floating currency, so need to look ahead.
+
+ if Look /= '$' then
+ Pic.End_Float := Pic.End_Float - 1;
+ end if;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if State = Okay then
+ raise Picture_Error;
+ else
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '$' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- A single dollar does not a floating make.
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one dollar before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Dollar;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Leading_Dollar;
+
+ -------------------
+ -- Leading_Pound --
+ -------------------
+
+ -- This one is complex! A Leading_Pound can be fixed or floating,
+ -- but in some cases the decision has to be deferred until we leave
+ -- this procedure. Also note that Leading_Pound can be called in
+ -- either State.
+
+ -- It will set state to Okay only if a 9 or (second) # is
+ -- encountered.
+
+ -- One Last note: In ambiguous cases, the currency is treated as
+ -- floating unless there is only one '#'.
+
+ procedure Leading_Pound is
+
+ Inserts : Boolean := False;
+ -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
+
+ Must_Float : Boolean := False;
+ -- Set to true if a '#' occurs after an insert.
+
+ begin
+ -- Treat as a floating currency. If it isn't, this will be
+ -- overwritten later.
+
+ Pic.Floater := '#';
+
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- currency place.
+
+ Pic.Max_Currency_Digits := 1; -- we've seen one.
+
+ Skip; -- known '#'
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Pic.End_Float := Index;
+ Inserts := True;
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Zero_Suppression;
+ end if;
+
+ when '*' =>
+ if Must_Float then
+ raise Picture_Error;
+ else
+ Pic.Max_Leading_Digits := 0;
+
+ -- Will overwrite Floater and Start_Float
+
+ Star_Suppression;
+ end if;
+
+ when '#' =>
+ if Inserts then
+ Must_Float := True;
+ end if;
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.End_Currency := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ if State /= Okay then
+
+ -- A single '#' doesn't float.
+
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Number_Completion;
+ return;
+
+ when 'V' | 'v' | '.' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Only one pound before the sign is okay,
+ -- but doesn't float.
+
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Pound;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Leading_Pound;
+
+ ----------
+ -- Look --
+ ----------
+
+ function Look return Character is
+ begin
+ if At_End then
+ raise Picture_Error;
+ end if;
+
+ return Pic.Picture.Expanded (Index);
+ end Look;
+
+ ------------
+ -- Number --
+ ------------
+
+ procedure Number is
+ begin
+ loop
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+
+ if At_End then
+ return;
+ end if;
+
+ -- Will return in Okay state if a '9' was seen.
+
+ end loop;
+ end Number;
+
+ -----------------------
+ -- Number_Completion --
+ -----------------------
+
+ procedure Number_Completion is
+ begin
+ while not At_End loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Completion;
+
+ ---------------------
+ -- Number_Fraction --
+ ---------------------
+
+ procedure Number_Fraction is
+ begin
+ -- Note that number fraction can be called in either State.
+ -- It will set state to Valid only if a 9 is encountered.
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Number_Fraction;
+
+ --------------------------------
+ -- Number_Fraction_Or_Bracket --
+ --------------------------------
+
+ procedure Number_Fraction_Or_Bracket is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Bracket;
+
+ -------------------------------
+ -- Number_Fraction_Or_Dollar --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Dollar is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Dollar;
+
+ ------------------------------
+ -- Number_Fraction_Or_Pound --
+ ------------------------------
+
+ procedure Number_Fraction_Or_Pound is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '#' =>
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Pound;
+
+ ----------------------------------
+ -- Number_Fraction_Or_Star_Fill --
+ ----------------------------------
+
+ procedure Number_Fraction_Or_Star_Fill is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.Star_Fill := True;
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+
+ end case;
+ end loop;
+ end Number_Fraction_Or_Star_Fill;
+
+ -------------------------------
+ -- Number_Fraction_Or_Z_Fill --
+ -------------------------------
+
+ procedure Number_Fraction_Or_Z_Fill is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Trailing_Digits :=
+ Pic.Max_Trailing_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+
+ when others =>
+ Number_Fraction;
+ return;
+ end case;
+ end loop;
+ end Number_Fraction_Or_Z_Fill;
+
+ -----------------------
+ -- Optional_RHS_Sign --
+ -----------------------
+
+ procedure Optional_RHS_Sign is
+ begin
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '+' | '-' =>
+ Pic.Sign_Position := Index;
+ Skip;
+ return;
+
+ when 'C' | 'c' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'C';
+ Skip;
+
+ if Look = 'R' or Look = 'r' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'R';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when 'D' | 'd' =>
+ Pic.Sign_Position := Index;
+ Pic.Picture.Expanded (Index) := 'D';
+ Skip;
+
+ if Look = 'B' or Look = 'b' then
+ Pic.Second_Sign := Index;
+ Pic.Picture.Expanded (Index) := 'B';
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ return;
+
+ when '>' =>
+ if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
+ Pic.Second_Sign := Index;
+ Skip;
+
+ else
+ raise Picture_Error;
+ end if;
+
+ when others =>
+ return;
+
+ end case;
+ end Optional_RHS_Sign;
+
+ -------------
+ -- Picture --
+ -------------
+
+ -- Note that Picture can be called in either State.
+
+ -- It will set state to Valid only if a 9 is encountered or floating
+ -- currency is called.
+
+ procedure Picture is
+ begin
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '$' =>
+ Leading_Dollar;
+ return;
+
+ when '#' =>
+ Leading_Pound;
+ return;
+
+ when '9' =>
+ Computed_BWZ := False;
+ Set_State (Okay);
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Skip;
+
+ when 'V' | 'v' | '.' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction;
+ Trailing_Currency;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture;
+
+ ---------------------
+ -- Picture_Bracket --
+ ---------------------
+
+ procedure Picture_Bracket is
+ begin
+ Pic.Sign_Position := Index;
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '<';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Bracket
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '<' =>
+ Set_State (Okay); -- "<<>" is enough.
+ Floating_Bracket;
+ Trailing_Currency;
+ Trailing_Bracket;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Trailing_Bracket;
+ Set_State (Okay);
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit
+
+ Picture;
+ Trailing_Bracket;
+ return;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+ end loop;
+ end Picture_Bracket;
+
+ -------------------
+ -- Picture_Minus --
+ -------------------
+
+ procedure Picture_Minus is
+ begin
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '-';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Minus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '-' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "-- " is enough.
+ Floating_Minus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+
+ -- Can't have Z and a floating sign.
+
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Minus;
+
+ ------------------
+ -- Picture_Plus --
+ ------------------
+
+ procedure Picture_Plus is
+ begin
+ Pic.Sign_Position := Index;
+
+ -- Treat as a floating sign, and unwind otherwise.
+
+ Pic.Floater := '+';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+
+ -- Don't increment Pic.Max_Leading_Digits, we need one "real"
+ -- sign place.
+
+ Skip; -- Known Plus
+
+ loop
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '+' =>
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Skip;
+ Set_State (Okay); -- "++" is enough.
+ Floating_Plus;
+ Trailing_Currency;
+ return;
+
+ when '$' | '#' | '9' | '*' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ Picture;
+ Set_State (Okay);
+ return;
+
+ when 'Z' | 'z' =>
+ if State = Okay then
+ Set_State (Reject);
+ end if;
+
+ -- Can't have Z and a floating sign.
+
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ -- '+Z' is acceptable
+
+ Set_State (Okay);
+
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ if State /= Okay then
+ Pic.Floater := '!';
+ Pic.Start_Float := Invalid_Position;
+ Pic.End_Float := Invalid_Position;
+ end if;
+
+ -- Don't assume that state is okay, haven't seen a digit.
+
+ Picture;
+ return;
+
+ when others =>
+ return;
+
+ end case;
+ end loop;
+ end Picture_Plus;
+
+ --------------------
+ -- Picture_String --
+ --------------------
+
+ procedure Picture_String is
+ begin
+ while Is_Insert loop
+ Skip;
+ end loop;
+
+ case Look is
+
+ when '$' | '#' =>
+ Picture;
+ Optional_RHS_Sign;
+
+ when '+' =>
+ Picture_Plus;
+
+ when '-' =>
+ Picture_Minus;
+
+ when '<' =>
+ Picture_Bracket;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+ Zero_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '*' =>
+ Star_Suppression;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when '9' | '.' | 'V' | 'v' =>
+ Number;
+ Trailing_Currency;
+ Optional_RHS_Sign;
+
+ when others =>
+ raise Picture_Error;
+
+ end case;
+
+ -- Blank when zero either if the PIC does not contain a '9' or if
+ -- requested by the user and no '*'
+
+ Pic.Blank_When_Zero :=
+ (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
+
+ -- Star fill if '*' and no '9'.
+
+ Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
+
+ if not At_End then
+ Set_State (Reject);
+ end if;
+
+ end Picture_String;
+
+ ---------------
+ -- Set_State --
+ ---------------
+
+ procedure Set_State (L : Legality) is
+ begin
+ State := L;
+ end Set_State;
+
+ ----------
+ -- Skip --
+ ----------
+
+ procedure Skip is
+ begin
+ Index := Index + 1;
+ end Skip;
+
+ ----------------------
+ -- Star_Suppression --
+ ----------------------
+
+ procedure Star_Suppression is
+ begin
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay);
+
+ -- Even a single * is a valid picture
+
+ Pic.Star_Fill := True;
+ Skip; -- Known *
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when '*' =>
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Set_State (Okay); Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Star_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others => raise Picture_Error;
+ end case;
+ end loop;
+ end Star_Suppression;
+
+ ----------------------
+ -- Trailing_Bracket --
+ ----------------------
+
+ procedure Trailing_Bracket is
+ begin
+ if Look = '>' then
+ Pic.Second_Sign := Index;
+ Skip;
+ else
+ raise Picture_Error;
+ end if;
+ end Trailing_Bracket;
+
+ -----------------------
+ -- Trailing_Currency --
+ -----------------------
+
+ procedure Trailing_Currency is
+ begin
+ if At_End then
+ return;
+ end if;
+
+ if Look = '$' then
+ Pic.Start_Currency := Index;
+ Pic.End_Currency := Index;
+ Skip;
+
+ else
+ while not At_End and then Look = '#' loop
+ if Pic.Start_Currency = Invalid_Position then
+ Pic.Start_Currency := Index;
+ end if;
+
+ Pic.End_Currency := Index;
+ Skip;
+ end loop;
+ end if;
+
+ loop
+ if At_End then
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' => Skip;
+
+ when 'B' | 'b' =>
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when others => return;
+ end case;
+ end loop;
+ end Trailing_Currency;
+
+ ----------------------
+ -- Zero_Suppression --
+ ----------------------
+
+ procedure Zero_Suppression is
+ begin
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
+ Pic.End_Float := Index;
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Skip; -- Known Z
+
+ loop
+ -- Even a single Z is a valid picture
+
+ if At_End then
+ Set_State (Okay);
+ return;
+ end if;
+
+ case Look is
+ when '_' | '0' | '/' =>
+ Pic.End_Float := Index;
+ Skip;
+
+ when 'B' | 'b' =>
+ Pic.End_Float := Index;
+ Pic.Picture.Expanded (Index) := 'b';
+ Skip;
+
+ when 'Z' | 'z' =>
+ Pic.Picture.Expanded (Index) := 'Z'; -- consistency
+
+ Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
+ Pic.End_Float := Index;
+ Set_State (Okay);
+ Skip;
+
+ when '9' =>
+ Set_State (Okay);
+ Number_Completion;
+ return;
+
+ when '.' | 'V' | 'v' =>
+ Pic.Radix_Position := Index;
+ Skip;
+ Number_Fraction_Or_Z_Fill;
+ return;
+
+ when '#' | '$' =>
+ Trailing_Currency;
+ Set_State (Okay);
+ return;
+
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Zero_Suppression;
+
+ -- Start of processing for Precalculate
+
+ begin
+ Picture_String;
+
+ if State = Reject then
+ raise Picture_Error;
+ end if;
+
+ exception
+
+ when Constraint_Error =>
+
+ -- To deal with special cases like null strings.
+
+ raise Picture_Error;
+
+ end Precalculate;
+
+ ----------------
+ -- To_Picture --
+ ----------------
+
+ function To_Picture
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Picture
+ is
+ Result : Picture;
+
+ begin
+ declare
+ Item : constant String := Expand (Pic_String);
+
+ begin
+ Result.Contents.Picture := (Item'Length, Item);
+ Result.Contents.Original_BWZ := Blank_When_Zero;
+ Result.Contents.Blank_When_Zero := Blank_When_Zero;
+ Precalculate (Result.Contents);
+ return Result;
+ end;
+
+ exception
+ when others =>
+ raise Picture_Error;
+
+ end To_Picture;
+
+ -------------
+ -- To_Wide --
+ -------------
+
+ function To_Wide (C : Character) return Wide_Character is
+ begin
+ return Wide_Character'Val (Character'Pos (C));
+ end To_Wide;
+
+ -----------
+ -- Valid --
+ -----------
+
+ function Valid
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Boolean
+ is
+ begin
+ declare
+ Expanded_Pic : constant String := Expand (Pic_String);
+ -- Raises Picture_Error if Item not well-formed
+
+ Format_Rec : Format_Record;
+
+ begin
+ Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
+ Format_Rec.Blank_When_Zero := Blank_When_Zero;
+ Format_Rec.Original_BWZ := Blank_When_Zero;
+ Precalculate (Format_Rec);
+
+ -- False only if Blank_When_0 is True but the pic string
+ -- has a '*'
+
+ return not Blank_When_Zero or
+ Strings_Fixed.Index (Expanded_Pic, "*") = 0;
+ end;
+
+ exception
+ when others => return False;
+
+ end Valid;
+
+end Ada.Wide_Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E D I T I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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.Wide_Text_IO.Editing is
+
+ type Picture is private;
+
+ function Valid
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Boolean;
+
+ function To_Picture
+ (Pic_String : in String;
+ Blank_When_Zero : in Boolean := False)
+ return Picture;
+
+ function Pic_String (Pic : in Picture) return String;
+ function Blank_When_Zero (Pic : in Picture) return Boolean;
+
+ Max_Picture_Length : constant := 64;
+
+ Picture_Error : exception;
+
+ Default_Currency : constant Wide_String := "$";
+ Default_Fill : constant Wide_Character := ' ';
+ Default_Separator : constant Wide_Character := ',';
+ Default_Radix_Mark : constant Wide_Character := '.';
+
+ generic
+ type Num is delta <> digits <>;
+ Default_Currency : in Wide_String :=
+ Wide_Text_IO.Editing.Default_Currency;
+ Default_Fill : in Wide_Character :=
+ Wide_Text_IO.Editing.Default_Fill;
+ Default_Separator : in Wide_Character :=
+ Wide_Text_IO.Editing.Default_Separator;
+ Default_Radix_Mark : in Wide_Character :=
+ Wide_Text_IO.Editing.Default_Radix_Mark;
+
+ package Decimal_Output is
+
+ function Length
+ (Pic : in Picture;
+ Currency : in Wide_String := Default_Currency)
+ return Natural;
+
+ function Valid
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency)
+ return Boolean;
+
+ function Image
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark)
+ return Wide_String;
+
+ procedure Put
+ (File : in File_Type;
+ Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark);
+
+ procedure Put
+ (Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : Num;
+ Pic : in Picture;
+ Currency : in Wide_String := Default_Currency;
+ Fill : in Wide_Character := Default_Fill;
+ Separator : in Wide_Character := Default_Separator;
+ Radix_Mark : in Wide_Character := Default_Radix_Mark);
+
+ end Decimal_Output;
+
+private
+ MAX_PICSIZE : constant := 50;
+ MAX_MONEYSIZE : constant := 10;
+ Invalid_Position : constant := -1;
+
+ subtype Pic_Index is Natural range 0 .. MAX_PICSIZE;
+
+ type Picture_Record (Length : Pic_Index := 0) is record
+ Expanded : String (1 .. Length);
+ end record;
+
+ type Format_Record is record
+ Picture : Picture_Record;
+ -- Read only
+
+ Blank_When_Zero : Boolean;
+ -- Read/write
+
+ Original_BWZ : Boolean;
+
+ -- The following components get written
+
+ Star_Fill : Boolean := False;
+
+ Radix_Position : Integer := Invalid_Position;
+
+ Sign_Position,
+ Second_Sign : Integer := Invalid_Position;
+
+ Start_Float,
+ End_Float : Integer := Invalid_Position;
+
+ Start_Currency,
+ End_Currency : Integer := Invalid_Position;
+
+ Max_Leading_Digits : Integer := 0;
+
+ Max_Trailing_Digits : Integer := 0;
+
+ Max_Currency_Digits : Integer := 0;
+
+ Floater : Wide_Character := '!';
+ -- Initialized to illegal value
+
+ end record;
+
+ type Picture is record
+ Contents : Format_Record;
+ end record;
+
+ type Number_Attributes is record
+ Negative : Boolean := False;
+
+ Has_Fraction : Boolean := False;
+
+ Start_Of_Int,
+ End_Of_Int,
+ Start_Of_Fraction,
+ End_Of_Fraction : Integer := Invalid_Position; -- invalid value
+ end record;
+
+ function Parse_Number_String (Str : String) return Number_Attributes;
+ -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no
+ -- trailing blanks...)
+
+ procedure Precalculate (Pic : in out Format_Record);
+ -- Precalculates fields from the user supplied data
+
+ function Format_Number
+ (Pic : Format_Record;
+ Number : String;
+ Currency_Symbol : Wide_String;
+ Fill_Character : Wide_Character;
+ Separator_Character : Wide_Character;
+ Radix_Point : Wide_Character)
+ return Wide_String;
+ -- Formats number according to Pic
+
+ function Expand (Picture : in String) return String;
+
+end Ada.Wide_Text_IO.Editing;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.WCh_Con; use System.WCh_Con;
+
+package body Ada.Wide_Text_IO.Enumeration_Aux is
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Store_Char
+ (File : File_Type;
+ WC : Wide_Character;
+ Buf : out Wide_String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow.
+
+ -- These definitions replace the ones in Ada.Characters.Handling, which
+ -- do not seem to work for some strange not understood reason ??? at
+ -- least in the OS/2 version.
+
+ function To_Lower (C : Character) return Character;
+ function To_Upper (C : Character) return Character;
+
+ ------------------
+ -- Get_Enum_Lit --
+ ------------------
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out Wide_String;
+ Buflen : out Natural)
+ is
+ ch : int;
+ WC : Wide_Character;
+
+ begin
+ Buflen := 0;
+ Load_Skip (TFT (File));
+ ch := Nextc (TFT (File));
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L)
+
+ if ch = Character'Pos (''') then
+ Get (File, WC);
+ Store_Char (File, WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch = LM or else ch = EOF then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (File, WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch /= Character'Pos (''') then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (File, WC, Buf, Buflen);
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter. Any wide character value
+ -- outside the normal Latin-1 range counts as a letter for this.
+
+ if ch < 255 and then not Is_Letter (Character'Val (ch)) then
+ return;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ loop
+ Get (File, WC);
+ Store_Char (File, WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ exit when ch = EOF;
+
+ if ch = Character'Pos ('_') then
+ exit when Buf (Buflen) = '_';
+
+ elsif ch = Character'Pos (ASCII.ESC) then
+ null;
+
+ elsif File.WC_Method in WC_Upper_Half_Encoding_Method
+ and then ch > 127
+ then
+ null;
+
+ else
+ exit when Is_Letter (Character'Val (ch))
+ and then not Is_Digit (Character'Val (ch));
+ end if;
+ end loop;
+ end if;
+ end Get_Enum_Lit;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_String;
+ Width : Field;
+ Set : Type_Set)
+ is
+ Actual_Width : constant Integer :=
+ Integer'Max (Integer (Width), Item'Length);
+
+ begin
+ Check_On_One_Line (TFT (File), Actual_Width);
+
+ if Set = Lower_Case and then Item (1) /= ''' then
+ declare
+ Iteml : Wide_String (Item'First .. Item'Last);
+
+ begin
+ for J in Item'Range loop
+ if Is_Character (Item (J)) then
+ Iteml (J) :=
+ To_Wide_Character (To_Lower (To_Character (Item (J))));
+ else
+ Iteml (J) := Item (J);
+ end if;
+ end loop;
+
+ Put (File, Iteml);
+ end;
+
+ else
+ Put (File, Item);
+ end if;
+
+ for J in 1 .. Actual_Width - Item'Length loop
+ Put (File, ' ');
+ end loop;
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out Wide_String;
+ Item : in Wide_String;
+ Set : Type_Set)
+ is
+ Ptr : Natural;
+
+ begin
+ if Item'Length > To'Length then
+ raise Layout_Error;
+
+ else
+ Ptr := To'First;
+ for J in Item'Range loop
+ if Set = Lower_Case
+ and then Item (1) /= '''
+ and then Is_Character (Item (J))
+ then
+ To (Ptr) :=
+ To_Wide_Character (To_Lower (To_Character (Item (J))));
+ else
+ To (Ptr) := Item (J);
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ while Ptr <= To'Last loop
+ To (Ptr) := ' ';
+ Ptr := Ptr + 1;
+ end loop;
+ end if;
+ end Puts;
+
+ -------------------
+ -- Scan_Enum_Lit --
+ -------------------
+
+ procedure Scan_Enum_Lit
+ (From : Wide_String;
+ Start : out Natural;
+ Stop : out Natural)
+ is
+ WC : Wide_Character;
+
+ -- Processing for Scan_Enum_Lit
+
+ begin
+ Start := From'First;
+
+ loop
+ if Start > From'Last then
+ raise End_Error;
+
+ elsif Is_Character (From (Start))
+ and then not Is_Blank (To_Character (From (Start)))
+ then
+ exit;
+
+ else
+ Start := Start + 1;
+ end if;
+ end loop;
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L
+ -- which is for the analogous case for reading from a file).
+
+ if From (Start) = ''' then
+ Stop := Start;
+
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+ end if;
+
+ if From (Stop) in ' ' .. '~'
+ or else From (Stop) >= Wide_Character'Val (16#80#)
+ then
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+
+ if From (Stop) = ''' then
+ return;
+ end if;
+ end if;
+ end if;
+
+ Stop := Stop - 1;
+ raise Data_Error;
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter, any wide character outside
+ -- the normal Latin-1 range is considered a letter for this test.
+
+ if Is_Character (From (Start))
+ and then not Is_Letter (To_Character (From (Start)))
+ then
+ raise Data_Error;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ Stop := Start + 1;
+ while Stop < From'Last loop
+ WC := From (Stop + 1);
+
+ exit when
+ Is_Character (WC)
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ (WC /= '_' or else From (Stop - 1) = '_');
+
+ Stop := Stop + 1;
+ end loop;
+ end if;
+
+ end Scan_Enum_Lit;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (File : File_Type;
+ WC : Wide_Character;
+ Buf : out Wide_String;
+ Ptr : in out Integer)
+ is
+ begin
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := WC;
+ end if;
+ end Store_Char;
+
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ --------------
+ -- To_Upper --
+ --------------
+
+ function To_Upper (C : Character) return Character is
+ begin
+ if C in 'a' .. 'z' then
+ return Character'Val (Character'Pos (C) - 32);
+ else
+ return C;
+ end if;
+ end To_Upper;
+
+end Ada.Wide_Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Text_IO.Enumeration_IO
+-- that are shared among separate instantiations.
+
+private package Ada.Wide_Text_IO.Enumeration_Aux is
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out Wide_String;
+ Buflen : out Natural);
+ -- Reads an enumeration literal value from the file, folds to upper case,
+ -- and stores the result in Buf, setting Buflen to the number of stored
+ -- characters (Buf has a lower bound of 1). If more than Buflen characters
+ -- are present in the literal, Data_Error is raised.
+
+ procedure Scan_Enum_Lit
+ (From : Wide_String;
+ Start : out Natural;
+ Stop : out Natural);
+ -- Scans an enumeration literal at the start of From, skipping any leading
+ -- spaces. Sets Start to the first character, Stop to the last character.
+ -- Raises End_Error if no enumeration literal is found.
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_String;
+ Width : Field;
+ Set : Type_Set);
+ -- Outputs the enumeration literal image stored in Item to the given File,
+ -- using the given Width and Set parameters (Item is always in upper case).
+
+ procedure Puts
+ (To : out Wide_String;
+ Item : in Wide_String;
+ Set : Type_Set);
+ -- Stores the enumeration literal image stored in Item to the string To,
+ -- padding with trailing spaces if necessary to fill To. Set is used to
+
+end Ada.Wide_Text_IO.Enumeration_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Enumeration_Aux;
+
+package body Ada.Wide_Text_IO.Enumeration_IO is
+
+ package Aux renames Ada.Wide_Text_IO.Enumeration_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (File : in File_Type; Item : out Enum) is
+ Buf : Wide_String (1 .. Enum'Width);
+ Buflen : Natural;
+
+ begin
+ Aux.Get_Enum_Lit (File, Buf, Buflen);
+ Item := Enum'Wide_Value (Buf (1 .. Buflen));
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get (Item : out Enum) is
+ begin
+ Get (Current_Input, Item);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Enum;
+ Last : out Positive)
+ is
+ Start : Natural;
+
+ begin
+ Aux.Scan_Enum_Lit (From, Start, Last);
+ Item := Enum'Wide_Value (From (Start .. Last));
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ Image : constant Wide_String := Enum'Wide_Image (Item);
+
+ begin
+ Aux.Put (File, Image, Width, Set);
+ end Put;
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ begin
+ Put (Current_Output, Item, Width, Set);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Enum;
+ Set : in Type_Set := Default_Setting)
+ is
+ Image : constant Wide_String := Enum'Wide_Image (Item);
+
+ begin
+ Aux.Puts (To, Image, Set);
+ end Put;
+
+end Ada.Wide_Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Enumeration_IO is a subpackage
+-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading the
+-- necessary code if Enumeration_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the difference
+-- in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Enum is (<>);
+
+package Ada.Wide_Text_IO.Enumeration_IO is
+
+ Default_Width : Field := 0;
+ Default_Setting : Type_Set := Upper_Case;
+
+ procedure Get (File : in File_Type; Item : out Enum);
+ procedure Get (Item : out Enum);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Enum;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Enum;
+ Set : in Type_Set := Default_Setting);
+
+end Ada.Wide_Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Float_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Fixed_IO is
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Fixed_IO is a subpackage of
+-- Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Fixed_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is delta <>;
+
+package Ada.Wide_Text_IO.Fixed_IO is
+
+ Default_Fore : Field := Num'Fore;
+ Default_Aft : Field := Num'Aft;
+ Default_Exp : Field := 0;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+end Ada.Wide_Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X --
+-- --
+-- 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 Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+
+with System.Img_Real; use System.Img_Real;
+with System.Val_Real; use System.Val_Real;
+
+package body Ada.Wide_Text_IO.Float_Aux is
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Long_Long_Float;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Real (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Real (Buf, Ptr'Access, Stop);
+
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get;
+
+ ----------
+ -- Gets --
+ ----------
+
+ procedure Gets
+ (From : in String;
+ Item : out Long_Long_Float;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Real (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+ end Gets;
+
+ ---------------
+ -- Load_Real --
+ ---------------
+
+ procedure Load_Real
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Loaded : Boolean;
+
+ begin
+ -- Skip initial blanks and load possible sign
+
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ -- Case of .nnnn
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Otherwise must have digits to start
+
+ else
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ -- Hopeless junk if no digits loaded
+
+ if not Loaded then
+ return;
+ end if;
+
+ -- Based cases
+
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+
+ -- Case of nnn#.xxx#
+
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+
+ -- Case of nnn#xxx.[xxx]# or nnn#xxx#
+
+ else
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Extended_Digits (File, Buf, Ptr);
+ end if;
+
+ -- As usual, it seems strange to allow mixed base characters,
+ -- but that is what ACVC tests expect, see CE3804M, case (3).
+
+ Load (File, Buf, Ptr, '#', ':');
+ end if;
+
+ -- Case of nnn.[nnn] or nnn
+
+ else
+ Load (File, Buf, Ptr, '.', Loaded);
+
+ if Loaded then
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- Deal with exponent
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end Load_Real;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Long_Long_Float;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out String;
+ Item : in Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+
+ else
+ for J in 1 .. Ptr loop
+ To (To'Last - Ptr + J) := Buf (J);
+ end loop;
+
+ for J in To'First .. To'Last - Ptr loop
+ To (J) := ' ';
+ end loop;
+ end if;
+ end Puts;
+
+end Ada.Wide_Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Text_IO.Float_IO that
+-- are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Float_IO itself,
+-- except that generic parameter Num has been replaced by Long_Long_Float,
+-- and the default parameters have been removed because they are supplied
+-- explicitly by the calls from within the generic template. This package
+-- is also used by Ada.Wide_Text_IO.Fixed_IO, Ada.Wide_Text_IO.Decimal_IO.
+
+private package Ada.Wide_Text_IO.Float_Aux is
+
+ procedure Load_Real
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load a possibly signed
+ -- real literal value from the input file into Buf, starting at Ptr + 1.
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Long_Long_Float;
+ Width : in Field);
+
+ procedure Gets
+ (From : in String;
+ Item : out Long_Long_Float;
+ Last : out Positive);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Long_Long_Float;
+ Fore : in Field;
+ Aft : in Field;
+ Exp : in Field);
+
+ procedure Puts
+ (To : out String;
+ Item : in Long_Long_Float;
+ Aft : in Field;
+ Exp : in Field);
+
+end Ada.Wide_Text_IO.Float_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F L O A T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Float_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Float_IO is
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Text_IO.Float_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Aux.Get (TFT (File), Long_Long_Float (Item), Width);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ Aux.Gets (S, Long_Long_Float (Item), Last);
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Current_Output, Item, Fore, Aft, Exp);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ Aux.Puts (S, Long_Long_Float (Item), Aft, Exp);
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . F L O A T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Float_IO is a subpackage
+-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Float_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is digits <>;
+
+package Ada.Wide_Text_IO.Float_IO is
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Num'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+end Ada.Wide_Text_IO.Float_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.File_IO;
+with System.File_Control_Block;
+
+package body Ada.Wide_Text_IO.Generic_Aux is
+
+ package FIO renames System.File_IO;
+ package FCB renames System.File_Control_Block;
+ subtype AP is FCB.AFCB_Ptr;
+
+ ------------------------
+ -- Check_End_Of_Field --
+ ------------------------
+
+ procedure Check_End_Of_Field
+ (File : File_Type;
+ Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field)
+ is
+ begin
+ if Ptr > Stop then
+ return;
+
+ elsif Width = 0 then
+ raise Data_Error;
+
+ else
+ for J in Ptr .. Stop loop
+ if not Is_Blank (Buf (J)) then
+ raise Data_Error;
+ end if;
+ end loop;
+ end if;
+ end Check_End_Of_Field;
+
+ -----------------------
+ -- Check_On_One_Line --
+ -----------------------
+
+ procedure Check_On_One_Line
+ (File : File_Type;
+ Length : Integer)
+ is
+ begin
+ FIO.Check_Write_Status (AP (File));
+
+ if File.Line_Length /= 0 then
+ if Count (Length) > File.Line_Length then
+ raise Layout_Error;
+ elsif File.Col + Count (Length) > File.Line_Length + 1 then
+ New_Line (File);
+ end if;
+ end if;
+ end Check_On_One_Line;
+
+ --------------
+ -- Is_Blank --
+ --------------
+
+ function Is_Blank (C : Character) return Boolean is
+ begin
+ return C = ' ' or else C = ASCII.HT;
+ end Is_Blank;
+
+ ----------
+ -- Load --
+ ----------
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Character then
+ null;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char) then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1)
+ or else ch = Character'Pos (Char2)
+ then
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ else
+ Ungetc (ch, File);
+ Loaded := False;
+ end if;
+ end if;
+ end Load;
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character)
+ is
+ ch : int;
+
+ begin
+ if File.Before_Wide_Character then
+ null;
+
+ else
+ ch := Getc (File);
+
+ if ch = Character'Pos (Char1)
+ or else ch = Character'Pos (Char2)
+ then
+ Store_Char (File, ch, Buf, Ptr);
+ else
+ Ungetc (ch, File);
+ end if;
+ end if;
+ end Load;
+
+ -----------------
+ -- Load_Digits --
+ -----------------
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ if File.Before_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch not in Character'Pos ('0') .. Character'Pos ('9') then
+ Loaded := False;
+
+ else
+ Loaded := True;
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Digits;
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+ After_Digit : Boolean;
+
+ begin
+ if File.Before_Wide_Character then
+ return;
+
+ else
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ loop
+ Store_Char (File, ch, Buf, Ptr);
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9') then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Digits;
+
+ --------------------------
+ -- Load_Extended_Digits --
+ --------------------------
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean)
+ is
+ ch : int;
+ After_Digit : Boolean := False;
+
+ begin
+ if File.Before_Wide_Character then
+ Loaded := False;
+ return;
+
+ else
+ Loaded := False;
+
+ loop
+ ch := Getc (File);
+
+ if ch in Character'Pos ('0') .. Character'Pos ('9')
+ or else
+ ch in Character'Pos ('a') .. Character'Pos ('f')
+ or else
+ ch in Character'Pos ('A') .. Character'Pos ('F')
+ then
+ After_Digit := True;
+
+ elsif ch = Character'Pos ('_') and then After_Digit then
+ After_Digit := False;
+
+ else
+ exit;
+ end if;
+
+ Store_Char (File, ch, Buf, Ptr);
+ Loaded := True;
+ end loop;
+
+ Ungetc (ch, File);
+ end if;
+ end Load_Extended_Digits;
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ Junk : Boolean;
+
+ begin
+ Load_Extended_Digits (File, Buf, Ptr, Junk);
+ end Load_Extended_Digits;
+
+ ---------------
+ -- Load_Skip --
+ ---------------
+
+ procedure Load_Skip (File : File_Type) is
+ C : Character;
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- We need to explicitly test for the case of being before a wide
+ -- character (greater than 16#7F#). Since no such character can
+ -- ever legitimately be a valid numeric character, we can
+ -- immediately signal Data_Error.
+
+ if File.Before_Wide_Character then
+ raise Data_Error;
+ end if;
+
+ -- Otherwise loop till we find a non-blank character (note that as
+ -- usual in Wide_Text_IO, blank includes horizontal tab). Note that
+ -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
+
+ loop
+ Get_Character (File, C);
+ exit when not Is_Blank (C);
+ end loop;
+
+ Ungetc (Character'Pos (C), File);
+ File.Col := File.Col - 1;
+ end Load_Skip;
+
+ ----------------
+ -- Load_Width --
+ ----------------
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : Field;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ ch : int;
+ WC : Wide_Character;
+
+ Bad_Wide_C : Boolean := False;
+ -- Set True if one of the characters read is not in range of type
+ -- Character. This is always a Data_Error, but we do not signal it
+ -- right away, since we have to read the full number of characters.
+
+ begin
+ FIO.Check_Read_Status (AP (File));
+
+ -- If we are immediately before a line mark, then we have no characters.
+ -- This is always a data error, so we may as well raise it right away.
+
+ if File.Before_LM then
+ raise Data_Error;
+
+ else
+ for J in 1 .. Width loop
+ if File.Before_Wide_Character then
+ Bad_Wide_C := True;
+ Store_Char (File, 0, Buf, Ptr);
+ File.Before_Wide_Character := False;
+
+ else
+ ch := Getc (File);
+
+ if ch = EOF then
+ exit;
+
+ elsif ch = LM then
+ Ungetc (ch, File);
+ exit;
+
+ else
+ WC := Get_Wide_Char (Character'Val (ch), File);
+ ch := Wide_Character'Pos (WC);
+
+ if ch > 255 then
+ Bad_Wide_C := True;
+ ch := 0;
+ end if;
+
+ Store_Char (File, ch, Buf, Ptr);
+ end if;
+ end if;
+ end loop;
+
+ if Bad_Wide_C then
+ raise Data_Error;
+ end if;
+ end if;
+ end Load_Width;
+
+ --------------
+ -- Put_Item --
+ --------------
+
+ procedure Put_Item (File : File_Type; Str : String) is
+ begin
+ Check_On_One_Line (File, Str'Length);
+
+ for J in Str'Range loop
+ Put (File, Wide_Character'Val (Character'Pos (Str (J))));
+ end loop;
+ end Put_Item;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : Integer;
+ Buf : out String;
+ Ptr : in out Integer)
+ is
+ begin
+ File.Col := File.Col + 1;
+
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := Character'Val (ch);
+ end if;
+ end Store_Char;
+
+ -----------------
+ -- String_Skip --
+ -----------------
+
+ procedure String_Skip (Str : String; Ptr : out Integer) is
+ begin
+ Ptr := Str'First;
+
+ loop
+ if Ptr > Str'Last then
+ raise End_Error;
+
+ elsif not Is_Blank (Str (Ptr)) then
+ return;
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+ end String_Skip;
+
+ ------------
+ -- Ungetc --
+ ------------
+
+ procedure Ungetc (ch : int; File : File_Type) is
+ begin
+ if ch /= EOF then
+ if ungetc (ch, File.Stream) = EOF then
+ raise Device_Error;
+ end if;
+ end if;
+ end Ungetc;
+
+end Ada.Wide_Text_IO.Generic_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains a set of auxiliary routines used by Wide_Text_IO
+-- generic children, including for reading and writing numeric strings.
+
+-- Note: although this is the Wide version of the package, the interface
+-- here is still in terms of Character and String rather than Wide_Character
+-- and Wide_String, since all numeric strings are composed entirely of
+-- characters in the range of type Standard.Character, and the basic
+-- conversion routines work with Character rather than Wide_Character.
+
+package Ada.Wide_Text_IO.Generic_Aux is
+
+ -- Note: for all the Load routines, File indicates the file to be read,
+ -- Buf is the string into which data is stored, Ptr is the index of the
+ -- last character stored so far, and is updated if additional characters
+ -- are stored. Data_Error is raised if the input overflows Buf. The only
+ -- Load routines that do a file status check are Load_Skip and Load_Width
+ -- so one of these two routines must be called first.
+
+ procedure Check_End_Of_Field
+ (File : File_Type;
+ Buf : String;
+ Stop : Integer;
+ Ptr : Integer;
+ Width : Field);
+ -- This routine is used after doing a get operations on a numeric value.
+ -- Buf is the string being scanned, and Stop is the last character of
+ -- the field being scanned. Ptr is as set by the call to the scan routine
+ -- that scanned out the numeric value, i.e. it points one past the last
+ -- character scanned, and Width is the width parameter from the Get call.
+ --
+ -- There are two cases, if Width is non-zero, then a check is made that
+ -- the remainder of the field is all blanks. If Width is zero, then it
+ -- means that the scan routine scanned out only part of the field. We
+ -- have already scanned out the field that the ACVC tests seem to expect
+ -- us to read (even if it does not follow the syntax of the type being
+ -- scanned, e.g. allowing negative exponents in integers, and underscores
+ -- at the end of the string), so we just raise Data_Error.
+
+ procedure Check_On_One_Line (File : File_Type; Length : Integer);
+ -- Check to see if item of length Integer characters can fit on
+ -- current line. Call New_Line if not, first checking that the
+ -- line length can accomodate Length characters, raise Layout_Error
+ -- if item is too large for a single line.
+
+ function Is_Blank (C : Character) return Boolean;
+ -- Determines if C is a blank (space or tab)
+
+ procedure Load_Width
+ (File : File_Type;
+ Width : in Field;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Loads exactly Width characters, unless a line mark is encountered first
+
+ procedure Load_Skip (File : File_Type);
+ -- Skips leading blanks and line and page marks, if the end of file is
+ -- read without finding a non-blank character, then End_Error is raised.
+ -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character;
+ Loaded : out Boolean);
+ -- If next character is Char, loads it, otherwise no characters are loaded
+ -- Loaded is set to indicate whether or not the character was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character;
+ Loaded : out Boolean);
+ -- If next character is Char1 or Char2, loads it, otherwise no characters
+ -- are loaded. Loaded is set to indicate whether or not one of the two
+ -- characters was found.
+
+ procedure Load
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Char1 : Character;
+ Char2 : Character);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Loads a sequence of zero or more decimal digits. Loaded is set if
+ -- at least one digit is loaded.
+
+ procedure Load_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer;
+ Loaded : out Boolean);
+ -- Like Load_Digits, but also allows extended digits a-f and A-F
+
+ procedure Load_Extended_Digits
+ (File : File_Type;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Same as above, but no indication if character is loaded
+
+ procedure Put_Item (File : File_Type; Str : String);
+ -- This routine is like Wide_Text_IO.Put, except that it checks for
+ -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used
+ -- for all output of numeric values and of enumeration values. Note that
+ -- the buffer is of type String. Put_Item deals with converting this to
+ -- Wide_Characters as required.
+
+ procedure Store_Char
+ (File : File_Type;
+ ch : Integer;
+ Buf : out String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow and
+ -- adjusting the column number in the file to reflect the fact
+ -- that a character has been acquired from the input stream.
+ -- The pos value of the character to store is in ch on entry.
+
+ procedure String_Skip (Str : String; Ptr : out Integer);
+ -- Used in the Get from string procedures to skip leading blanks in the
+ -- string. Ptr is set to the index of the first non-blank. If the string
+ -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is defined as a space or horizontal tab (RM A.10.6(5)).
+
+ procedure Ungetc (ch : Integer; File : File_Type);
+ -- Pushes back character into stream, using ungetc. The caller has
+ -- checked that the file is in read status. Device_Error is raised
+ -- if the character cannot be pushed back. An attempt to push back
+ -- an end of file (EOF) is ignored.
+
+private
+ pragma Inline (Is_Blank);
+
+end Ada.Wide_Text_IO.Generic_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Int; use System.Img_Int;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLI; use System.Img_LLI;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Int; use System.Val_Int;
+with System.Val_LLI; use System.Val_LLI;
+
+package body Ada.Wide_Text_IO.Integer_Aux is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Integer
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- integer literal value from the input file into Buf, starting at Ptr + 1.
+ -- On return, Ptr is set to the last character stored.
+
+ -------------
+ -- Get_Int --
+ -------------
+
+ procedure Get_Int
+ (File : in File_Type;
+ Item : out Integer;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_Int;
+
+ -------------
+ -- Get_LLI --
+ -------------
+
+ procedure Get_LLI
+ (File : in File_Type;
+ Item : out Long_Long_Integer;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : aliased Integer := 1;
+ Stop : Integer := 0;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Integer (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_LLI;
+
+ --------------
+ -- Gets_Int --
+ --------------
+
+ procedure Gets_Int
+ (From : in String;
+ Item : out Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+
+ end Gets_Int;
+
+ --------------
+ -- Gets_LLI --
+ --------------
+
+ procedure Gets_LLI
+ (From : in String;
+ Item : out Long_Long_Integer;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+
+ end Gets_LLI;
+
+ ------------------
+ -- Load_Integer --
+ ------------------
+
+ procedure Load_Integer
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+ Load (File, Buf, Ptr, '+', '-');
+
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Integer;
+
+ -------------
+ -- Put_Int --
+ -------------
+
+ procedure Put_Int
+ (File : in File_Type;
+ Item : in Integer;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Int;
+
+ -------------
+ -- Put_LLI --
+ -------------
+
+ procedure Put_LLI
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Integer (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLI;
+
+ --------------
+ -- Puts_Int --
+ --------------
+
+ procedure Puts_Int
+ (To : out String;
+ Item : in Integer;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Int;
+
+ --------------
+ -- Puts_LLI --
+ --------------
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLI;
+
+end Ada.Wide_Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Text_IO.Integer_IO that
+-- are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Integer_IO itself,
+-- except that the generic parameter Num has been replaced by Integer or
+-- Long_Long_Integer, and the default parameters have been removed because
+-- they are supplied explicitly by the calls from within the generic template.
+
+private package Ada.Wide_Text_IO.Integer_Aux is
+
+ procedure Get_Int
+ (File : in File_Type;
+ Item : out Integer;
+ Width : in Field);
+
+ procedure Get_LLI
+ (File : in File_Type;
+ Item : out Long_Long_Integer;
+ Width : in Field);
+
+ procedure Gets_Int
+ (From : in String;
+ Item : out Integer;
+ Last : out Positive);
+
+ procedure Gets_LLI
+ (From : in String;
+ Item : out Long_Long_Integer;
+ Last : out Positive);
+
+ procedure Put_Int
+ (File : in File_Type;
+ Item : in Integer;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Put_LLI
+ (File : in File_Type;
+ Item : in Long_Long_Integer;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Puts_Int
+ (To : out String;
+ Item : in Integer;
+ Base : in Number_Base);
+
+ procedure Puts_LLI
+ (To : out String;
+ Item : in Long_Long_Integer;
+ Base : in Number_Base);
+
+end Ada.Wide_Text_IO.Integer_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO.Integer_Aux;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Integer_IO is
+
+ Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
+ -- Throughout this generic body, we distinguish between the case
+ -- where type Integer is acceptable, and where a Long_Long_Integer
+ -- is needed. This constant Boolean is used to test for these cases
+ -- and since it is a constant, only the code for the relevant case
+ -- will be included in the instance.
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Text_IO.Integer_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ if Need_LLI then
+ Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width);
+ else
+ Aux.Get_Int (TFT (File), Integer (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Need_LLI then
+ Aux.Gets_LLI (S, Long_Long_Integer (Item), Last);
+ else
+ Aux.Gets_Int (S, Integer (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Need_LLI then
+ Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base);
+ else
+ Aux.Put_Int (TFT (File), Integer (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Need_LLI then
+ Aux.Puts_LLI (S, Long_Long_Integer (Item), Base);
+ else
+ Aux.Puts_Int (S, Integer (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Integer_IO is a subpackage
+-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading
+-- the necessary code if Integer_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is range <>;
+
+package Ada.Wide_Text_IO.Integer_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base);
+
+end Ada.Wide_Text_IO.Integer_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
+
+with System.Img_BIU; use System.Img_BIU;
+with System.Img_Uns; use System.Img_Uns;
+with System.Img_LLB; use System.Img_LLB;
+with System.Img_LLU; use System.Img_LLU;
+with System.Img_LLW; use System.Img_LLW;
+with System.Img_WIU; use System.Img_WIU;
+with System.Val_Uns; use System.Val_Uns;
+with System.Val_LLU; use System.Val_LLU;
+
+package body Ada.Wide_Text_IO.Modular_Aux is
+
+ use System.Unsigned_Types;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Load_Modular
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural);
+ -- This is an auxiliary routine that is used to load an possibly signed
+ -- modular literal value from the input file into Buf, starting at Ptr + 1.
+ -- Ptr is left set to the last character stored.
+
+ -------------
+ -- Get_LLU --
+ -------------
+
+ procedure Get_LLU
+ (File : in File_Type;
+ Item : out Long_Long_Unsigned;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_LLU;
+
+ -------------
+ -- Get_Uns --
+ -------------
+
+ procedure Get_Uns
+ (File : in File_Type;
+ Item : out Unsigned;
+ Width : in Field)
+ is
+ Buf : String (1 .. Field'Last);
+ Stop : Integer := 0;
+ Ptr : aliased Integer := 1;
+
+ begin
+ if Width /= 0 then
+ Load_Width (File, Width, Buf, Stop);
+ String_Skip (Buf, Ptr);
+ else
+ Load_Modular (File, Buf, Stop);
+ end if;
+
+ Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
+ Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
+ end Get_Uns;
+
+ --------------
+ -- Gets_LLU --
+ --------------
+
+ procedure Gets_LLU
+ (From : in String;
+ Item : out Long_Long_Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+
+ end Gets_LLU;
+
+ --------------
+ -- Gets_Uns --
+ --------------
+
+ procedure Gets_Uns
+ (From : in String;
+ Item : out Unsigned;
+ Last : out Positive)
+ is
+ Pos : aliased Integer;
+
+ begin
+ String_Skip (From, Pos);
+ Item := Scan_Unsigned (From, Pos'Access, From'Last);
+ Last := Pos - 1;
+
+ exception
+ when Constraint_Error =>
+ Last := Pos - 1;
+ raise Data_Error;
+
+ end Gets_Uns;
+
+ ------------------
+ -- Load_Modular --
+ ------------------
+
+ procedure Load_Modular
+ (File : in File_Type;
+ Buf : out String;
+ Ptr : in out Natural)
+ is
+ Hash_Loc : Natural;
+ Loaded : Boolean;
+
+ begin
+ Load_Skip (File);
+
+ -- Note: it is a bit strange to allow a minus sign here, but it seems
+ -- consistent with the general behavior expected by the ACVC tests
+ -- which is to scan past junk and then signal data error, see ACVC
+ -- test CE3704F, case (6), which is for signed integer exponents,
+ -- which seems a similar case.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr, Loaded);
+
+ if Loaded then
+ Load (File, Buf, Ptr, '#', ':', Loaded);
+
+ if Loaded then
+ Hash_Loc := Ptr;
+ Load_Extended_Digits (File, Buf, Ptr);
+ Load (File, Buf, Ptr, Buf (Hash_Loc));
+ end if;
+
+ Load (File, Buf, Ptr, 'E', 'e', Loaded);
+
+ if Loaded then
+
+ -- Note: it is strange to allow a minus sign, since the syntax
+ -- does not, but that is what ACVC test CE3704F, case (6) wants
+ -- for the signed case, and there seems no good reason to treat
+ -- exponents differently for the signed and unsigned cases.
+
+ Load (File, Buf, Ptr, '+', '-');
+ Load_Digits (File, Buf, Ptr);
+ end if;
+ end if;
+ end Load_Modular;
+
+ -------------
+ -- Put_LLU --
+ -------------
+
+ procedure Put_LLU
+ (File : in File_Type;
+ Item : in Long_Long_Unsigned;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_LLU;
+
+ -------------
+ -- Put_Uns --
+ -------------
+
+ procedure Put_Uns
+ (File : in File_Type;
+ Item : in Unsigned;
+ Width : in Field;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 and then Width = 0 then
+ Set_Image_Unsigned (Item, Buf, Ptr);
+ elsif Base = 10 then
+ Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
+ end if;
+
+ Put_Item (File, Buf (1 .. Ptr));
+ end Put_Uns;
+
+ --------------
+ -- Puts_LLU --
+ --------------
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : in Long_Long_Unsigned;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_LLU;
+
+ --------------
+ -- Puts_Uns --
+ --------------
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : in Unsigned;
+ Base : in Number_Base)
+ is
+ Buf : String (1 .. Field'Last);
+ Ptr : Natural := 0;
+
+ begin
+ if Base = 10 then
+ Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
+ else
+ Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
+ end if;
+
+ if Ptr > To'Length then
+ raise Layout_Error;
+ else
+ To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
+ end if;
+ end Puts_Uns;
+
+end Ada.Wide_Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines for Ada.Wide_Text_IO.Modular_IO that
+-- are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Modular_IO itself,
+-- except that the generic parameter Num has been replaced by Unsigned or
+-- Long_Long_Unsigned, and the default parameters have been removed because
+-- they are supplied explicitly by the calls from within the generic template.
+
+with System.Unsigned_Types;
+
+private package Ada.Wide_Text_IO.Modular_Aux is
+
+ package U renames System.Unsigned_Types;
+
+ procedure Get_Uns
+ (File : in File_Type;
+ Item : out U.Unsigned;
+ Width : in Field);
+
+ procedure Get_LLU
+ (File : in File_Type;
+ Item : out U.Long_Long_Unsigned;
+ Width : in Field);
+
+ procedure Gets_Uns
+ (From : in String;
+ Item : out U.Unsigned;
+ Last : out Positive);
+
+ procedure Gets_LLU
+ (From : in String;
+ Item : out U.Long_Long_Unsigned;
+ Last : out Positive);
+
+ procedure Put_Uns
+ (File : in File_Type;
+ Item : in U.Unsigned;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Put_LLU
+ (File : in File_Type;
+ Item : in U.Long_Long_Unsigned;
+ Width : in Field;
+ Base : in Number_Base);
+
+ procedure Puts_Uns
+ (To : out String;
+ Item : in U.Unsigned;
+ Base : in Number_Base);
+
+ procedure Puts_LLU
+ (To : out String;
+ Item : in U.Long_Long_Unsigned;
+ Base : in Number_Base);
+
+end Ada.Wide_Text_IO.Modular_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.Wide_Text_IO.Modular_Aux;
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body Ada.Wide_Text_IO.Modular_IO is
+
+ subtype TFT is Ada.Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ package Aux renames Ada.Wide_Text_IO.Modular_Aux;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width);
+ else
+ Aux.Get_Uns (TFT (File), Unsigned (Item), Width);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0)
+ is
+ begin
+ Get (Current_Input, Item, Width);
+ end Get;
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive)
+ is
+ S : constant String := Wide_String_To_String (From, WCEM_Upper);
+ -- String on which we do the actual conversion. Note that the method
+ -- used for wide character encoding is irrelevant, since if there is
+ -- a character outside the Standard.Character range then the call to
+ -- Aux.Gets will raise Data_Error in any case.
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last);
+ else
+ Aux.Gets_Uns (S, Unsigned (Item), Last);
+ end if;
+
+ exception
+ when Constraint_Error => raise Data_Error;
+ end Get;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base);
+ else
+ Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base);
+ end if;
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base)
+ is
+ begin
+ Put (Current_Output, Item, Width, Base);
+ end Put;
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base)
+ is
+ S : String (To'First .. To'Last);
+
+ begin
+ if Num'Size > Unsigned'Size then
+ Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base);
+ else
+ Aux.Puts_Uns (S, Unsigned (Item), Base);
+ end if;
+
+ for J in S'Range loop
+ To (J) := Wide_Character'Val (Character'Pos (S (J)));
+ end loop;
+ end Put;
+
+end Ada.Wide_Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- In Ada 95, the package Ada.Wide_Text_IO.Modular_IO is a subpackage of
+-- Wide_Text_IO. In GNAT we make it a child package to avoid loading the
+-- necessary code if Modular_IO is not instantiated. See the routine
+-- Rtsfind.Text_IO_Kludge for a description of how we patch up the
+-- difference in semantics so that it is invisible to the Ada programmer.
+
+private generic
+ type Num is range <>;
+
+package Ada.Wide_Text_IO.Modular_IO is
+
+ Default_Width : Field := Num'Width;
+ Default_Base : Number_Base := 10;
+
+ procedure Get
+ (File : in File_Type;
+ Item : out Num;
+ Width : in Field := 0);
+
+ procedure Get
+ (Item : out Num;
+ Width : in Field := 0);
+
+ procedure Put
+ (File : in File_Type;
+ Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Put
+ (Item : in Num;
+ Width : in Field := Default_Width;
+ Base : in Number_Base := Default_Base);
+
+ procedure Get
+ (From : in Wide_String;
+ Item : out Num;
+ Last : out Positive);
+
+ procedure Put
+ (To : out Wide_String;
+ Item : in Num;
+ Base : in Number_Base := Default_Base);
+
+end Ada.Wide_Text_IO.Modular_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- 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.File_IO;
+
+package body Ada.Wide_Text_IO.Text_Streams is
+
+ ------------
+ -- Stream --
+ ------------
+
+ function Stream (File : in File_Type) return Stream_Access is
+ begin
+ System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File));
+ return Stream_Access (File);
+ end Stream;
+
+end Ada.Wide_Text_IO.Text_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Streams;
+
+package Ada.Wide_Text_IO.Text_Streams is
+
+ type Stream_Access is access all Streams.Root_Stream_Type'Class;
+
+ function Stream (File : in File_Type) return Stream_Access;
+
+end Ada.Wide_Text_IO.Text_Streams;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * GNAT-SPECIFIC GCC TREE CODES *
+ * *
+ * Specification *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * 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). *
+ * *
+ ****************************************************************************/
+
+/* A GNAT tree node to transform to a GCC tree. This is only used when the
+ node would generate code, rather then just a tree, and we are in the global
+ context.
+
+ The only field used is TREE_COMPLEXITY, which contains the GNAT node
+ number. */
+
+DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0)
+
+/* Perform an unchecked conversion between the input and the output.
+ if TREE_ADDRESSABLE is set, it means this is in an LHS; in that case,
+ we can only use techniques, such as pointer punning, that leave the
+ expression a "name". */
+
+DEFTREECODE (UNCHECKED_CONVERT_EXPR, "unchecked_convert_expr", '1', 1)
+
+/* Dynamically allocate on the stack a number of bytes of memory given
+ by operand 0 at the alignment given by operand 1 and return the
+ address of the resulting memory. */
+
+DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2)
+
+/* A type that is an unconstrained array itself. This node is never passed
+ to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE
+ is the type of a record containing the template and data. */
+
+DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", 't', 0)
+
+/* A reference to an unconstrained array. This node only exists as an
+ intermediate node during the translation of a GNAT tree to a GCC tree;
+ it is never passed to GCC. The only field used is operand 0, which
+ is the fat pointer object. */
+
+DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref", 'r', 1)
+
+/* An expression that returns an RTL suitable for its type. Operand 0
+ is an expression to be evaluated for side effects only. */
+
+DEFTREECODE (NULL_EXPR, "null_expr", 'e', 1)
+
+/* An expression that emits a USE for its single operand. */
+
+DEFTREECODE (USE_EXPR, "use_expr", 'e', 1)
+
+/* Same as ADDR_EXPR, except that if the operand represents a bit field,
+ return the address of the byte containing the bit. This is used
+ for the 'Address attribute and never shows up in the tree. */
+DEFTREECODE (ATTR_ADDR_EXPR, "attr_addr_expr", 'r', 1)
+
+/* An expression that is treated as a conversion while generating code, but is
+ used to prevent infinite recursion when conversions of biased types are
+ involved. */
+
+DEFTREECODE (GNAT_NOP_EXPR, "gnat_nop_expr", '1', 1)
+
+/* This is used as a place to store the ID of a loop.
+
+ ??? This should be redone at some point. */
+
+DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 1)
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A D A - T R E E *
+ * *
+ * C Header File *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * 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). *
+ * *
+ ****************************************************************************/
+
+/* Ada language-specific GC tree codes. */
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) SYM,
+enum gnat_tree_code {
+ __DUMMY = LAST_AND_UNUSED_TREE_CODE,
+#include "ada-tree.def"
+ LAST_GNAT_TREE_CODE
+};
+#undef DEFTREECODE
+
+/* Flags added to GCC type nodes. */
+
+/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a
+ record being used as a fat pointer (only true for RECORD_TYPE). */
+#define TYPE_IS_FAT_POINTER_P(NODE) TYPE_LANG_FLAG_0 (NODE)
+
+#define TYPE_FAT_POINTER_P(NODE) \
+ (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE))
+
+/* For integral types, nonzero if this is a packed array type. Such
+ types should not be extended to a larger size. */
+#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
+
+/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that
+ is not equal to two to the power of its mode's size. */
+#define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE))
+
+/* For ARRAY_TYPE, nonzero if this type corresponds to a dimension of
+ an Ada array other than the first. */
+#define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE))
+
+/* For FUNCTION_TYPE, nonzero if this denotes a function returning an
+ unconstrained array or record. */
+#define TYPE_RETURNS_UNCONSTRAINED_P(NODE) \
+ TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE))
+
+/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes
+ a left-justified modular type (will only be true for RECORD_TYPE). */
+#define TYPE_LEFT_JUSTIFIED_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (NODE)
+
+/* Nonzero in an arithmetic subtype if this is a subtype not known to the
+ front-end. */
+#define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE)
+
+/* Nonzero for composite types if this is a by-reference type. */
+#define TYPE_BY_REFERENCE_P(NODE) TYPE_LANG_FLAG_2 (NODE)
+
+/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the
+ type for an object whose type includes its template in addition to
+ its value (only true for RECORD_TYPE). */
+#define TYPE_CONTAINS_TEMPLATE_P(NODE) TYPE_LANG_FLAG_3 (NODE)
+
+/* For INTEGER_TYPE, nonzero if this really represents a VAX
+ floating-point type. */
+#define TYPE_VAX_FLOATING_POINT_P(NODE) \
+ TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE))
+
+/* True if NODE is a thin pointer. */
+#define TYPE_THIN_POINTER_P(NODE) \
+ (POINTER_TYPE_P (NODE) \
+ && TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \
+ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE)))
+
+/* True if TYPE is either a fat or thin pointer to an unconstrained
+ array. */
+#define TYPE_FAT_OR_THIN_POINTER_P(NODE) \
+ (TYPE_FAT_POINTER_P (NODE) || TYPE_THIN_POINTER_P (NODE))
+
+/* For INTEGER_TYPEs, nonzero if the type has a biased representation. */
+#define TYPE_BIASED_REPRESENTATION_P(NODE) \
+ TYPE_LANG_FLAG_4 (INTEGER_TYPE_CHECK (NODE))
+
+/* For ARRAY_TYPEs, nonzero if the array type has Convention_Fortran. */
+#define TYPE_CONVENTION_FORTRAN_P(NODE) \
+ TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE))
+
+/* For FUNCTION_TYPEs, nonzero if the function returns by reference. */
+#define TYPE_RETURNS_BY_REF_P(NODE) \
+ TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE))
+
+/* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this
+ is a dummy type, made to correspond to a private or incomplete type. */
+#define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE)
+
+/* True if TYPE is such a dummy type. */
+#define TYPE_IS_DUMMY_P(NODE) \
+ ((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \
+ || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \
+ && TYPE_DUMMY_P (NODE))
+
+/* Nonzero if this corresponds to a type where alignment is guaranteed
+ by other mechanisms (a tagged or packed type). */
+#define TYPE_ALIGN_OK_P(NODE) TYPE_LANG_FLAG_5 (NODE)
+
+/* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */
+#define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \
+ TYPE_LANG_FLAG_6 (INTEGER_TYPE_CHECK (NODE))
+
+/* For a RECORD_TYPE, nonzero if this was made just to supply needed
+ padding or alignment. */
+#define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_6 (RECORD_TYPE_CHECK (NODE))
+
+/* This field is only defined for FUNCTION_TYPE nodes. If the Ada
+ subprogram contains no parameters passed by copy in/copy out then this
+ field is 0. Otherwise it points to a list of nodes used to specify the
+ return values of the out (or in out) parameters that qualify to be passed
+ by copy in copy out. It is a CONSTRUCTOR. For a full description of the
+ cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */
+#define TYPE_CI_CO_LIST(NODE) \
+ (tree) TYPE_LANG_SPECIFIC (FUNCTION_TYPE_CHECK (NODE))
+
+/* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the
+ modulus. */
+#define TYPE_MODULUS(NODE) \
+ (tree) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
+
+/* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to
+ the type corresponding to the Ada index type. */
+#define TYPE_INDEX_TYPE(NODE) \
+ (tree) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
+
+/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the
+ Digits_Value. */
+#define TYPE_DIGITS_VALUE(NODE) \
+ (long) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
+
+/* For INTEGER_TYPE, stores the RM_Size of the type. */
+#define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE))
+
+/* Likewise for ENUMERAL_TYPE. */
+#define TYPE_RM_SIZE_ENUM(NODE) \
+ (tree) TYPE_LANG_SPECIFIC (ENUMERAL_TYPE_CHECK (NODE))
+
+#define TYPE_RM_SIZE(NODE) \
+ (TREE_CODE (NODE) == ENUMERAL_TYPE ? TYPE_RM_SIZE_ENUM (NODE) \
+ : TREE_CODE (NODE) == INTEGER_TYPE ? TYPE_RM_SIZE_INT (NODE) \
+ : 0)
+
+/* For a RECORD_TYPE that is a fat pointer, point to the type for the
+ unconstrained object. Likewise for a RECORD_TYPE that is pointed
+ to by a thin pointer. */
+#define TYPE_UNCONSTRAINED_ARRAY(NODE) \
+ (tree) TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE))
+
+/* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada
+ size of the object. This differs from the GCC size in that it does not
+ include any rounding up to the alignment of the type. */
+#define TYPE_ADA_SIZE(NODE) (tree) TYPE_LANG_SPECIFIC (NODE)
+
+/* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is
+ the index type that should be used when the actual bounds are required for
+ a template. This is used in the case of packed arrays. */
+#define TYPE_ACTUAL_BOUNDS(NODE) (tree) TYPE_LANG_SPECIFIC (NODE)
+
+/* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both
+ the template and object. */
+#define TYPE_OBJECT_RECORD_TYPE(NODE) TYPE_MIN_VALUE (NODE)
+
+/* Nonzero in a FUNCTION_DECL that represents a stubbed function
+ discriminant. */
+#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE))
+
+/* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF
+ is needed to access the object. */
+#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE)
+
+/* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a
+ foreign convention subprogram. */
+#define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_2 (NODE)
+
+/* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */
+#define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE))
+
+/* Nonzero in a FUNCTION_DECL that corresponds to an elaboration procedure. */
+#define DECL_ELABORATION_PROC_P(NODE) \
+ DECL_LANG_FLAG_3 (FUNCTION_DECL_CHECK (NODE))
+
+/* Nonzero if this is a decl for a pointer that points to something which
+ is readonly. Used mostly for fat pointers. */
+#define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE)
+
+/* Nonzero in a FIELD_DECL if there was a record rep clause. */
+#define DECL_HAS_REP_P(NODE) DECL_LANG_FLAG_5 (FIELD_DECL_CHECK (NODE))
+
+/* Nonzero in a PARM_DECL if we are to pass by descriptor. */
+#define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE))
+
+/* In a CONST_DECL, points to a VAR_DECL that is allocatable to
+ memory. Used when a scalar constant is aliased or has its
+ address taken. */
+#define DECL_CONST_CORRESPONDING_VAR(NODE) \
+ (tree) DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE))
+
+/* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate
+ source of the decl. */
+#define DECL_ORIGINAL_FIELD(NODE) \
+ (tree) DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE))
+
+/* In a FIELD_DECL corresponding to a discriminant, contains the
+ discriminant number. */
+#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
+
+/* This is a horrible kludge to store the loop_id of a loop into a tree
+ node. We need to find some other place to store it! */
+#define TREE_LOOP_ID(NODE) (TREE_CHECK (NODE, GNAT_LOOP_ID)->real_cst.rtl)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A --
+-- --
+-- 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 is
+pragma Pure (Ada);
+
+end Ada;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A D A *
+ * *
+ * C Header File *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+/* This file contains some standard macros for performing Ada-like
+ operations. These are used to aid in the translation of other headers. */
+
+/* Inlined functions in header are preceded by INLINE, which is normally set
+ to extern inline for GCC, but may be set to static for use in standard
+ ANSI-C. */
+
+#ifndef INLINE
+#ifdef __GNUC__
+#define INLINE static inline
+#else
+#define INLINE static
+#endif
+#endif
+
+/* Define a macro to concatenate two strings. Write it for ANSI C and
+ for traditional C. */
+
+#ifdef __STDC__
+#define CAT(A,B) A##B
+#else
+#define _ECHO(A) A
+#define CAT(A,B) ECHO(A)B
+#endif
+
+/* The following macro definition simulates the effect of a declaration of
+ a subtype, where the first two parameters give the name of the type and
+ subtype, and the third and fourth parameters give the subtype range. The
+ effect is to compile a typedef defining the subtype as a synonym for the
+ type, together with two constants defining the end points. */
+
+#define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \
+ typedef TYPE SUBTYPE; \
+ static const SUBTYPE CAT (SUBTYPE,__First) = FIRST; \
+ static const SUBTYPE CAT (SUBTYPE,__Last) = LAST;
+
+/* The following definitions provide the equivalent of the Ada IN and NOT IN
+ operators, assuming that the subtype involved has been defined using the
+ SUBTYPE macro defined above. */
+
+#define IN(VALUE,SUBTYPE) \
+ (((VALUE) >= CAT (SUBTYPE,__First)) && ((VALUE) <= CAT (SUBTYPE,__Last)))
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A D A I N T *
+ * *
+ * $Revision: 1.2 $
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+/* This file contains those routines named by Import pragmas in packages */
+/* in the GNAT hierarchy (especially GNAT.OS_Lib) and in package Osint. */
+/* Many of the subprograms in OS_Lib import standard library calls */
+/* directly. This file contains all other routines. */
+
+#ifdef __vxworks
+/* No need to redefine exit here */
+#ifdef exit
+#undef exit
+#endif
+/* We want to use the POSIX variants of include files. */
+#define POSIX
+#include "vxWorks.h"
+
+#if defined (__mips_vxworks)
+#include "cacheLib.h"
+#endif /* __mips_vxworks */
+
+#endif /* VxWorks */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <time.h>
+
+/* We don't have libiberty, so us malloc. */
+#define xmalloc(S) malloc (S)
+#else
+#include "config.h"
+#include "system.h"
+#endif
+#include <sys/wait.h>
+
+#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
+#include <process.h>
+#endif
+
+#if defined (_WIN32)
+#include <dir.h>
+#include <windows.h>
+#endif
+
+#include "adaint.h"
+
+/* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
+ defined in the current system. On DOS-like systems these flags control
+ whether the file is opened/created in text-translation mode (CR/LF in
+ external file mapped to LF in internal file), but in Unix-like systems,
+ no text translation is required, so these flags have no effect. */
+
+#if defined (__EMX__)
+#include <os2.h>
+#endif
+
+#if defined (MSDOS)
+#include <dos.h>
+#endif
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#ifndef O_TEXT
+#define O_TEXT 0
+#endif
+
+#ifndef HOST_EXECUTABLE_SUFFIX
+#define HOST_EXECUTABLE_SUFFIX ""
+#endif
+
+#ifndef HOST_OBJECT_SUFFIX
+#define HOST_OBJECT_SUFFIX ".o"
+#endif
+
+#ifndef PATH_SEPARATOR
+#define PATH_SEPARATOR ':'
+#endif
+
+#ifndef DIR_SEPARATOR
+#define DIR_SEPARATOR '/'
+#endif
+
+char __gnat_dir_separator = DIR_SEPARATOR;
+
+char __gnat_path_separator = PATH_SEPARATOR;
+
+/* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
+ the base filenames that libraries specified with -lsomelib options
+ may have. This is used by GNATMAKE to check whether an executable
+ is up-to-date or not. The syntax is
+
+ library_template ::= { pattern ; } pattern NUL
+ pattern ::= [ prefix ] * [ postfix ]
+
+ These should only specify names of static libraries as it makes
+ no sense to determine at link time if dynamic-link libraries are
+ up to date or not. Any libraries that are not found are supposed
+ to be up-to-date:
+
+ * if they are needed but not present, the link
+ will fail,
+
+ * otherwise they are libraries in the system paths and so
+ they are considered part of the system and not checked
+ for that reason.
+
+ ??? This should be part of a GNAT host-specific compiler
+ file instead of being included in all user applications
+ as well. This is only a temporary work-around for 3.11b. */
+
+#ifndef GNAT_LIBRARY_TEMPLATE
+#if defined(__EMX__)
+#define GNAT_LIBRARY_TEMPLATE "*.a"
+#elif defined(VMS)
+#define GNAT_LIBRARY_TEMPLATE "*.olb"
+#else
+#define GNAT_LIBRARY_TEMPLATE "lib*.a"
+#endif
+#endif
+
+const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
+
+/* The following macro HAVE_READDIR_R should be defined if the
+ system provides the routine readdir_r */
+#undef HAVE_READDIR_R
+\f
+void
+__gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
+ time_t *p_time;
+ int *p_year, *p_month, *p_day, *p_hours, *p_mins, *p_secs;
+{
+ struct tm *res;
+ time_t time = *p_time;
+
+#ifdef _WIN32
+ /* On Windows systems, the time is sometimes rounded up to the nearest
+ even second, so if the number of seconds is odd, increment it. */
+ if (time & 1)
+ time++;
+#endif
+
+ res = gmtime (&time);
+
+ if (res)
+ {
+ *p_year = res->tm_year;
+ *p_month = res->tm_mon;
+ *p_day = res->tm_mday;
+ *p_hours = res->tm_hour;
+ *p_mins = res->tm_min;
+ *p_secs = res->tm_sec;
+ }
+ else
+ *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
+}
+
+/* Place the contents of the symbolic link named PATH in the buffer BUF,
+ which has size BUFSIZ. If PATH is a symbolic link, then return the number
+ of characters of its content in BUF. Otherwise, return -1. For Windows,
+ OS/2 and vxworks, always return -1. */
+
+int
+__gnat_readlink (path, buf, bufsiz)
+ char *path;
+ char *buf;
+ size_t bufsiz;
+{
+#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
+ return -1;
+#elif defined (__INTERIX) || defined (VMS)
+ return -1;
+#elif defined (__vxworks)
+ return -1;
+#else
+ return readlink (path, buf, bufsiz);
+#endif
+}
+
+/* Creates a symbolic link named newpath
+ which contains the string oldpath.
+ If newpath exists it will NOT be overwritten.
+ For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */
+
+int
+__gnat_symlink (oldpath, newpath)
+ char *oldpath;
+ char *newpath;
+{
+#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
+ return -1;
+#elif defined (__INTERIX) || defined (VMS)
+ return -1;
+#elif defined (__vxworks)
+ return -1;
+#else
+ return symlink (oldpath, newpath);
+#endif
+}
+
+/* Try to lock a file, return 1 if success */
+
+#if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
+
+/* Version that does not use link. */
+
+int
+__gnat_try_lock (dir, file)
+ char *dir;
+ char *file;
+{
+ char full_path [256];
+ int fd;
+
+ sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
+ fd = open (full_path, O_CREAT | O_EXCL, 0600);
+ if (fd < 0) {
+ return 0;
+ }
+ close (fd);
+ return 1;
+}
+
+#elif defined (__EMX__) || defined (VMS)
+
+/* More cases that do not use link; identical code, to solve too long
+ line problem ??? */
+
+int
+__gnat_try_lock (dir, file)
+ char *dir;
+ char *file;
+{
+ char full_path [256];
+ int fd;
+
+ sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
+ fd = open (full_path, O_CREAT | O_EXCL, 0600);
+ if (fd < 0)
+ return 0;
+
+ close (fd);
+ return 1;
+}
+
+#else
+/* Version using link(), more secure over NFS. */
+
+int
+__gnat_try_lock (dir, file)
+ char *dir;
+ char *file;
+{
+ char full_path [256];
+ char temp_file [256];
+ struct stat stat_result;
+ int fd;
+
+ sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
+ sprintf (temp_file, "%s-%d-%d", dir, getpid(), getppid ());
+
+ /* Create the temporary file and write the process number */
+ fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
+ if (fd < 0)
+ return 0;
+
+ close (fd);
+
+ /* Link it with the new file */
+ link (temp_file, full_path);
+
+ /* Count the references on the old one. If we have a count of two, then
+ the link did succeed. Remove the temporary file before returning. */
+ __gnat_stat (temp_file, &stat_result);
+ unlink (temp_file);
+ return stat_result.st_nlink == 2;
+}
+#endif
+
+/* Return the maximum file name length. */
+
+int
+__gnat_get_maximum_file_name_length ()
+{
+#if defined(MSDOS)
+ return 8;
+#elif defined (VMS)
+ if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
+ return -1;
+ else
+ return 39;
+#else
+ return -1;
+#endif
+}
+
+/* Return the default switch character. */
+
+char
+__gnat_get_switch_character ()
+{
+ /* Under MSDOS, the switch character is not normally a hyphen, but this is
+ the convention DJGPP uses. Similarly under OS2, the switch character is
+ not normally a hypen, but this is the convention EMX uses. */
+
+ return '-';
+}
+
+/* Return nonzero if file names are case sensitive. */
+
+int
+__gnat_get_file_names_case_sensitive ()
+{
+#if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined(WINNT)
+ return 0;
+#else
+ return 1;
+#endif
+}
+
+char
+__gnat_get_default_identifier_character_set ()
+{
+#if defined (__EMX__) || defined (MSDOS)
+ return 'p';
+#else
+ return '1';
+#endif
+}
+
+/* Return the current working directory */
+
+void
+__gnat_get_current_dir (dir, length)
+ char *dir;
+ int *length;
+{
+#ifdef VMS
+ /* Force Unix style, which is what GNAT uses internally. */
+ getcwd (dir, *length, 0);
+#else
+ getcwd (dir, *length);
+#endif
+
+ *length = strlen (dir);
+
+ dir [*length] = DIR_SEPARATOR;
+ ++(*length);
+ dir [*length] = '\0';
+}
+
+/* Return the suffix for object files. */
+
+void
+__gnat_get_object_suffix_ptr (len, value)
+ int *len;
+ const char **value;
+{
+ *value = HOST_OBJECT_SUFFIX;
+
+ if (*value == 0)
+ *len = 0;
+ else
+ *len = strlen (*value);
+
+ return;
+}
+
+/* Return the suffix for executable files */
+
+void
+__gnat_get_executable_suffix_ptr (len, value)
+ int *len;
+ const char **value;
+{
+ *value = HOST_EXECUTABLE_SUFFIX;
+ if (!*value)
+ *len = 0;
+ else
+ *len = strlen (*value);
+
+ return;
+}
+
+/* Return the suffix for debuggable files. Usually this is the same as the
+ executable extension. */
+
+void
+__gnat_get_debuggable_suffix_ptr (len, value)
+ int *len;
+ const char **value;
+{
+#ifndef MSDOS
+ *value = HOST_EXECUTABLE_SUFFIX;
+#else
+ /* On DOS, the extensionless COFF file is what gdb likes. */
+ *value = "";
+#endif
+
+ if (*value == 0)
+ *len = 0;
+ else
+ *len = strlen (*value);
+
+ return;
+}
+
+int
+__gnat_open_read (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ /* Optional arguments mbc,deq,fop increase read performance */
+ fd = open (path, O_RDONLY | o_fmode, 0444,
+ "mbc=16", "deq=64", "fop=tef");
+#elif defined(__vxworks)
+ fd = open (path, O_RDONLY | o_fmode, 0444);
+#else
+ fd = open (path, O_RDONLY | o_fmode);
+#endif
+ return fd < 0 ? -1 : fd;
+}
+
+#if defined (__EMX__)
+#define PERM (S_IREAD | S_IWRITE)
+#else
+#define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
+#endif
+
+int
+__gnat_open_rw (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ fd = open (path, O_RDWR | o_fmode, PERM,
+ "mbc=16", "deq=64", "fop=tef");
+#else
+ fd = open (path, O_RDWR | o_fmode, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+int
+__gnat_open_create (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
+ "mbc=16", "deq=64", "fop=tef");
+#else
+ fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+int
+__gnat_open_append (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
+ "mbc=16", "deq=64", "fop=tef");
+#else
+ fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+/* Open a new file. Return error (-1) if the file already exists. */
+
+int
+__gnat_open_new (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
+ "mbc=16", "deq=64", "fop=tef");
+#else
+ fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+/* Open a new temp file. Return error (-1) if the file already exists.
+ Special options for VMS allow the file to be shared between parent and
+ child processes, however they really slow down output. Used in
+ gnatchop. */
+
+int
+__gnat_open_new_temp (path, fmode)
+ char *path;
+ int fmode;
+{
+ int fd;
+ int o_fmode = O_BINARY;
+
+ strcpy (path, "GNAT-XXXXXX");
+
+#if defined (linux) && !defined (__vxworks)
+ return mkstemp (path);
+
+#else
+ if (mktemp (path) == NULL)
+ return -1;
+#endif
+
+ if (fmode)
+ o_fmode = O_TEXT;
+
+#if defined(VMS)
+ fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
+ "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
+ "mbc=16", "deq=64", "fop=tef");
+#else
+ fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+int
+__gnat_mkdir (dir_name)
+ char *dir_name;
+{
+ /* On some systems, mkdir has two args and on some it has one. If we
+ are being built as part of the compiler, autoconf has figured that out
+ for us. Otherwise, we have to do it ourselves. */
+#ifndef IN_RTS
+ return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
+#else
+#if defined (_WIN32) || defined (__vxworks)
+ return mkdir (dir_name);
+#else
+ return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
+#endif
+#endif
+}
+
+/* Return the number of bytes in the specified file. */
+
+long
+__gnat_file_length (fd)
+ int fd;
+{
+ int ret;
+ struct stat statbuf;
+
+ ret = fstat (fd, &statbuf);
+ if (ret || !S_ISREG (statbuf.st_mode))
+ return 0;
+
+ return (statbuf.st_size);
+}
+
+/* Create a temporary filename and put it in string pointed to by
+ tmp_filename */
+
+void
+__gnat_tmp_name (tmp_filename)
+ char *tmp_filename;
+{
+#ifdef __MINGW32__
+ {
+ char *pname;
+
+ /* tempnam tries to create a temporary file in directory pointed to by
+ TMP environment variable, in c:\temp if TMP is not set, and in
+ directory specified by P_tmpdir in stdio.h if c:\temp does not
+ exist. The filename will be created with the prefix "gnat-". */
+
+ pname = (char *) tempnam ("c:\\temp", "gnat-");
+
+ /* if pname start with a back slash and not path information it means that
+ the filename is valid for the current working directory */
+
+ if (pname[0] == '\\')
+ {
+ strcpy (tmp_filename, ".\\");
+ strcat (tmp_filename, pname+1);
+ }
+ else
+ strcpy (tmp_filename, pname);
+
+ free (pname);
+ }
+#elif defined (linux)
+ char *tmpdir = getenv ("TMPDIR");
+
+ if (tmpdir == NULL)
+ strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
+ else
+ sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
+
+ close (mkstemp(tmp_filename));
+#else
+ tmpnam (tmp_filename);
+#endif
+}
+
+/* Read the next entry in a directory. The returned string points somewhere
+ in the buffer. */
+
+char *
+__gnat_readdir (dirp, buffer)
+ DIR *dirp;
+ char* buffer;
+{
+ /* If possible, try to use the thread-safe version. */
+#ifdef HAVE_READDIR_R
+ if (readdir_r (dirp, buffer) != NULL)
+ return ((struct dirent*) buffer)->d_name;
+ else
+ return NULL;
+
+#else
+ struct dirent *dirent = readdir (dirp);
+
+ if (dirent != NULL)
+ {
+ strcpy (buffer, dirent->d_name);
+ return buffer;
+ }
+ else
+ return NULL;
+
+#endif
+}
+
+/* Returns 1 if readdir is thread safe, 0 otherwise. */
+
+int
+__gnat_readdir_is_thread_safe ()
+{
+#ifdef HAVE_READDIR_R
+ return 1;
+#else
+ return 0;
+#endif
+}
+
+#ifdef _WIN32
+
+/* Returns the file modification timestamp using Win32 routines which are
+ immune against daylight saving time change. It is in fact not possible to
+ use fstat for this purpose as the DST modify the st_mtime field of the
+ stat structure. */
+
+static time_t
+win32_filetime (h)
+ HANDLE h;
+{
+ BOOL res;
+ FILETIME t_create;
+ FILETIME t_access;
+ FILETIME t_write;
+ unsigned long long timestamp;
+
+ /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
+ unsigned long long offset = 11644473600;
+
+ /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
+ since <Jan 1st 1601>. This function must return the number of seconds
+ since <Jan 1st 1970>. */
+
+ res = GetFileTime (h, &t_create, &t_access, &t_write);
+
+ timestamp = (((long long) t_write.dwHighDateTime << 32)
+ + t_write.dwLowDateTime);
+
+ timestamp = timestamp / 10000000 - offset;
+
+ return (time_t) timestamp;
+}
+#endif
+
+/* Return a GNAT time stamp given a file name. */
+
+time_t
+__gnat_file_time_name (name)
+ char *name;
+{
+ struct stat statbuf;
+
+#if defined (__EMX__) || defined (MSDOS)
+ int fd = open (name, O_RDONLY | O_BINARY);
+ time_t ret = __gnat_file_time_fd (fd);
+ close (fd);
+ return ret;
+
+#elif defined (_WIN32)
+ HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
+ OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
+ time_t ret = win32_filetime (h);
+ CloseHandle (h);
+ return ret;
+#else
+
+ (void) __gnat_stat (name, &statbuf);
+#ifdef VMS
+ /* VMS has file versioning */
+ return statbuf.st_ctime;
+#else
+ return statbuf.st_mtime;
+#endif
+#endif
+}
+
+/* Return a GNAT time stamp given a file descriptor. */
+
+time_t
+__gnat_file_time_fd (fd)
+ int fd;
+{
+ /* The following workaround code is due to the fact that under EMX and
+ DJGPP fstat attempts to convert time values to GMT rather than keep the
+ actual OS timestamp of the file. By using the OS2/DOS functions directly
+ the GNAT timestamp are independent of this behavior, which is desired to
+ facilitate the distribution of GNAT compiled libraries. */
+
+#if defined (__EMX__) || defined (MSDOS)
+#ifdef __EMX__
+
+ FILESTATUS fs;
+ int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
+ sizeof (FILESTATUS));
+
+ unsigned file_year = fs.fdateLastWrite.year;
+ unsigned file_month = fs.fdateLastWrite.month;
+ unsigned file_day = fs.fdateLastWrite.day;
+ unsigned file_hour = fs.ftimeLastWrite.hours;
+ unsigned file_min = fs.ftimeLastWrite.minutes;
+ unsigned file_tsec = fs.ftimeLastWrite.twosecs;
+
+#else
+ struct ftime fs;
+ int ret = getftime (fd, &fs);
+
+ unsigned file_year = fs.ft_year;
+ unsigned file_month = fs.ft_month;
+ unsigned file_day = fs.ft_day;
+ unsigned file_hour = fs.ft_hour;
+ unsigned file_min = fs.ft_min;
+ unsigned file_tsec = fs.ft_tsec;
+#endif
+
+ /* Calculate the seconds since epoch from the time components. First count
+ the whole days passed. The value for years returned by the DOS and OS2
+ functions count years from 1980, so to compensate for the UNIX epoch which
+ begins in 1970 start with 10 years worth of days and add days for each
+ four year period since then. */
+
+ time_t tot_secs;
+ int cum_days [12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
+ int days_passed = 3652 + (file_year / 4) * 1461;
+ int years_since_leap = file_year % 4;
+
+ if (years_since_leap == 1)
+ days_passed += 366;
+ else if (years_since_leap == 2)
+ days_passed += 731;
+ else if (years_since_leap == 3)
+ days_passed += 1096;
+
+ if (file_year > 20)
+ days_passed -= 1;
+
+ days_passed += cum_days [file_month - 1];
+ if (years_since_leap == 0 && file_year != 20 && file_month > 2)
+ days_passed++;
+
+ days_passed += file_day - 1;
+
+ /* OK - have whole days. Multiply -- then add in other parts. */
+
+ tot_secs = days_passed * 86400;
+ tot_secs += file_hour * 3600;
+ tot_secs += file_min * 60;
+ tot_secs += file_tsec * 2;
+ return tot_secs;
+
+#elif defined (_WIN32)
+ HANDLE h = (HANDLE) _get_osfhandle (fd);
+ time_t ret = win32_filetime (h);
+ CloseHandle (h);
+ return ret;
+
+#else
+ struct stat statbuf;
+
+ (void) fstat (fd, &statbuf);
+
+#ifdef VMS
+ /* VMS has file versioning */
+ return statbuf.st_ctime;
+#else
+ return statbuf.st_mtime;
+#endif
+#endif
+}
+
+void
+__gnat_get_env_value_ptr (name, len, value)
+ char *name;
+ int *len;
+ char **value;
+{
+ *value = getenv (name);
+ if (!*value)
+ *len = 0;
+ else
+ *len = strlen (*value);
+
+ return;
+}
+
+/* VMS specific declarations for set_env_value. */
+
+#ifdef VMS
+
+static char *to_host_path_spec PROTO ((char *));
+
+struct descriptor_s
+{
+ unsigned short len, mbz;
+ char *adr;
+};
+
+typedef struct _ile3
+{
+ unsigned short len, code;
+ char *adr;
+ unsigned short *retlen_adr;
+} ile_s;
+
+#endif
+
+void
+__gnat_set_env_value (name, value)
+ char *name;
+ char *value;
+{
+#ifdef MSDOS
+
+#elif defined (VMS)
+ struct descriptor_s name_desc;
+ /* Put in JOB table for now, so that the project stuff at least works */
+ struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
+ char *host_pathspec = to_host_path_spec (value);
+ char *copy_pathspec;
+ int num_dirs_in_pathspec = 1;
+ char *ptr;
+
+ if (*host_pathspec == 0)
+ return;
+
+ name_desc.len = strlen (name);
+ name_desc.mbz = 0;
+ name_desc.adr = name;
+
+ ptr = host_pathspec;
+ while (*ptr++)
+ if (*ptr == ',')
+ num_dirs_in_pathspec++;
+
+ {
+ int i, status;
+ ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
+ char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
+ char *curr, *next;
+
+ strcpy (copy_pathspec, host_pathspec);
+ curr = copy_pathspec;
+ for (i = 0; i < num_dirs_in_pathspec; i++)
+ {
+ next = strchr (curr, ',');
+ if (next == 0)
+ next = strchr (curr, 0);
+
+ *next = 0;
+ ile_array [i].len = strlen (curr);
+
+ /* Code 2 from lnmdef.h means its a string */
+ ile_array [i].code = 2;
+ ile_array [i].adr = curr;
+
+ /* retlen_adr is ignored */
+ ile_array [i].retlen_adr = 0;
+ curr = next + 1;
+ }
+
+ /* Terminating item must be zero */
+ ile_array [i].len = 0;
+ ile_array [i].code = 0;
+ ile_array [i].adr = 0;
+ ile_array [i].retlen_adr = 0;
+
+ status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
+ if ((status & 1) != 1)
+ LIB$SIGNAL (status);
+ }
+
+#else
+ int size = strlen (name) + strlen (value) + 2;
+ char *expression;
+
+ expression = (char *) xmalloc (size * sizeof (char));
+
+ sprintf (expression, "%s=%s", name, value);
+ putenv (expression);
+#endif
+}
+
+#ifdef _WIN32
+#include <windows.h>
+#endif
+
+/* Get the list of installed standard libraries from the
+ HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
+ key. */
+
+char *
+__gnat_get_libraries_from_registry ()
+{
+ char *result = (char *) "";
+
+#if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
+
+ HKEY reg_key;
+ DWORD name_size, value_size;
+ char name[256];
+ char value[256];
+ DWORD type;
+ DWORD index;
+ LONG res;
+
+ /* First open the key. */
+ res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
+
+ if (res == ERROR_SUCCESS)
+ res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
+ KEY_READ, ®_key);
+
+ if (res == ERROR_SUCCESS)
+ res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
+
+ if (res == ERROR_SUCCESS)
+ res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
+
+ /* If the key exists, read out all the values in it and concatenate them
+ into a path. */
+ for (index = 0; res == ERROR_SUCCESS; index++)
+ {
+ value_size = name_size = 256;
+ res = RegEnumValue (reg_key, index, name, &name_size, 0,
+ &type, value, &value_size);
+
+ if (res == ERROR_SUCCESS && type == REG_SZ)
+ {
+ char *old_result = result;
+
+ result = (char *) xmalloc (strlen (old_result) + value_size + 2);
+ strcpy (result, old_result);
+ strcat (result, value);
+ strcat (result, ";");
+ }
+ }
+
+ /* Remove the trailing ";". */
+ if (result[0] != 0)
+ result[strlen (result) - 1] = 0;
+
+#endif
+ return result;
+}
+
+int
+__gnat_stat (name, statbuf)
+ char *name;
+ struct stat *statbuf;
+{
+#ifdef _WIN32
+ /* Under Windows the directory name for the stat function must not be
+ terminated by a directory separator except if just after a drive name. */
+ int name_len = strlen (name);
+ char last_char = name [name_len - 1];
+ char win32_name [4096];
+
+ strcpy (win32_name, name);
+
+ while (name_len > 1 && (last_char == '\\' || last_char == '/'))
+ {
+ win32_name [name_len - 1] = '\0';
+ name_len--;
+ last_char = win32_name[name_len - 1];
+ }
+
+ if (name_len == 2 && win32_name [1] == ':')
+ strcat (win32_name, "\\");
+
+ return stat (win32_name, statbuf);
+
+#else
+ return stat (name, statbuf);
+#endif
+}
+
+int
+__gnat_file_exists (name)
+ char *name;
+{
+ struct stat statbuf;
+
+ return !__gnat_stat (name, &statbuf);
+}
+
+int
+__gnat_is_absolute_path (name)
+ char *name;
+{
+ return (*name == '/' || *name == DIR_SEPARATOR
+#if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
+ || strlen (name) > 1 && isalpha (name [0]) && name [1] == ':'
+#endif
+ );
+}
+
+int
+__gnat_is_regular_file (name)
+ char *name;
+{
+ int ret;
+ struct stat statbuf;
+
+ ret = __gnat_stat (name, &statbuf);
+ return (!ret && S_ISREG (statbuf.st_mode));
+}
+
+int
+__gnat_is_directory (name)
+ char *name;
+{
+ int ret;
+ struct stat statbuf;
+
+ ret = __gnat_stat (name, &statbuf);
+ return (!ret && S_ISDIR (statbuf.st_mode));
+}
+
+int
+__gnat_is_writable_file (name)
+ char *name;
+{
+ int ret;
+ int mode;
+ struct stat statbuf;
+
+ ret = __gnat_stat (name, &statbuf);
+ mode = statbuf.st_mode & S_IWUSR;
+ return (!ret && mode);
+}
+
+#ifdef VMS
+/* Defined in VMS header files */
+#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
+ LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
+#endif
+
+#if defined (sun) && defined (__SVR4)
+/* Using fork on Solaris will duplicate all the threads. fork1, which
+ duplicates only the active thread, must be used instead, or spawning
+ subprocess from a program with tasking will lead into numerous problems. */
+#define fork fork1
+#endif
+
+int
+__gnat_portable_spawn (args)
+ char *args[];
+{
+ int status = 0;
+ int finished;
+ int pid;
+
+#if defined (MSDOS) || defined (_WIN32)
+ status = spawnvp (P_WAIT, args [0], args);
+ if (status < 0)
+ return 4;
+ else
+ return status;
+
+#elif defined(__vxworks) /* Mods for VxWorks */
+ pid = sp (args[0], args); /* Spawn process and save pid */
+ if (pid == -1)
+ return (4);
+
+ while (taskIdVerify(pid) >= 0)
+ /* Wait until spawned task is complete then continue. */
+ ;
+#else
+
+#ifdef __EMX__
+ pid = spawnvp (P_NOWAIT, args [0], args);
+ if (pid == -1)
+ return (4);
+#else
+ pid = fork ();
+ if (pid == -1)
+ return (4);
+
+ if (pid == 0 && execv (args [0], args) != 0)
+ _exit (1);
+#endif
+
+ /* The parent */
+ finished = waitpid (pid, &status, 0);
+
+ if (finished != pid || WIFEXITED (status) == 0)
+ return 4;
+
+ return WEXITSTATUS (status);
+#endif
+ return 0;
+}
+
+/* WIN32 code to implement a wait call that wait for any child process */
+#ifdef _WIN32
+
+/* Synchronization code, to be thread safe. */
+
+static CRITICAL_SECTION plist_cs;
+
+void
+__gnat_plist_init ()
+{
+ InitializeCriticalSection (&plist_cs);
+}
+
+static void
+plist_enter ()
+{
+ EnterCriticalSection (&plist_cs);
+}
+
+void
+plist_leave ()
+{
+ LeaveCriticalSection (&plist_cs);
+}
+
+typedef struct _process_list
+{
+ HANDLE h;
+ struct _process_list *next;
+} Process_List;
+
+static Process_List *PLIST = NULL;
+
+static int plist_length = 0;
+
+static void
+add_handle (h)
+ HANDLE h;
+{
+ Process_List *pl;
+
+ pl = (Process_List *) xmalloc (sizeof (Process_List));
+
+ plist_enter();
+
+ /* -------------------- critical section -------------------- */
+ pl->h = h;
+ pl->next = PLIST;
+ PLIST = pl;
+ ++plist_length;
+ /* -------------------- critical section -------------------- */
+
+ plist_leave();
+}
+
+void remove_handle (h)
+ HANDLE h;
+{
+ Process_List *pl, *prev;
+
+ plist_enter();
+
+ /* -------------------- critical section -------------------- */
+ pl = PLIST;
+ while (pl)
+ {
+ if (pl->h == h)
+ {
+ if (pl == PLIST)
+ PLIST = pl->next;
+ else
+ prev->next = pl->next;
+ free (pl);
+ break;
+ }
+ else
+ {
+ prev = pl;
+ pl = pl->next;
+ }
+ }
+
+ --plist_length;
+ /* -------------------- critical section -------------------- */
+
+ plist_leave();
+}
+
+static int
+win32_no_block_spawn (command, args)
+ char *command;
+ char *args[];
+{
+ BOOL result;
+ STARTUPINFO SI;
+ PROCESS_INFORMATION PI;
+ SECURITY_ATTRIBUTES SA;
+
+ char full_command [2000];
+ int k;
+
+ /* Startup info. */
+ SI.cb = sizeof (STARTUPINFO);
+ SI.lpReserved = NULL;
+ SI.lpReserved2 = NULL;
+ SI.lpDesktop = NULL;
+ SI.cbReserved2 = 0;
+ SI.lpTitle = NULL;
+ SI.dwFlags = 0;
+ SI.wShowWindow = SW_HIDE;
+
+ /* Security attributes. */
+ SA.nLength = sizeof (SECURITY_ATTRIBUTES);
+ SA.bInheritHandle = TRUE;
+ SA.lpSecurityDescriptor = NULL;
+
+ /* Prepare the command string. */
+ strcpy (full_command, command);
+ strcat (full_command, " ");
+
+ k = 1;
+ while (args[k])
+ {
+ strcat (full_command, args[k]);
+ strcat (full_command, " ");
+ k++;
+ }
+
+ result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE,
+ NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI);
+
+ if (result == TRUE)
+ {
+ add_handle (PI.hProcess);
+ CloseHandle (PI.hThread);
+ return (int) PI.hProcess;
+ }
+ else
+ return -1;
+}
+
+static int
+win32_wait (status)
+ int *status;
+{
+ DWORD exitcode;
+ HANDLE *hl;
+ HANDLE h;
+ DWORD res;
+ int k;
+ Process_List *pl;
+
+ if (plist_length == 0)
+ {
+ errno = ECHILD;
+ return -1;
+ }
+
+ hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
+
+ k = 0;
+ plist_enter();
+
+ /* -------------------- critical section -------------------- */
+ pl = PLIST;
+ while (pl)
+ {
+ hl[k++] = pl->h;
+ pl = pl->next;
+ }
+ /* -------------------- critical section -------------------- */
+
+ plist_leave();
+
+ res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
+ h = hl [res - WAIT_OBJECT_0];
+ free (hl);
+
+ remove_handle (h);
+
+ GetExitCodeProcess (h, &exitcode);
+ CloseHandle (h);
+
+ *status = (int) exitcode;
+ return (int) h;
+}
+
+#endif
+
+int
+__gnat_portable_no_block_spawn (args)
+ char *args[];
+{
+ int pid = 0;
+
+#if defined (__EMX__) || defined (MSDOS)
+
+ /* ??? For PC machines I (Franco) don't know the system calls to implement
+ this routine. So I'll fake it as follows. This routine will behave
+ exactly like the blocking portable_spawn and will systematically return
+ a pid of 0 unless the spawned task did not complete successfully, in
+ which case we return a pid of -1. To synchronize with this the
+ portable_wait below systematically returns a pid of 0 and reports that
+ the subprocess terminated successfully. */
+
+ if (spawnvp (P_WAIT, args [0], args) != 0)
+ return -1;
+
+#elif defined (_WIN32)
+
+ pid = win32_no_block_spawn (args[0], args);
+ return pid;
+
+#elif defined (__vxworks) /* Mods for VxWorks */
+ pid = sp (args[0], args); /* Spawn task and then return (no waiting) */
+ if (pid == -1)
+ return (4);
+
+ return pid;
+
+#else
+ pid = fork ();
+
+ if (pid == 0 && execv (args [0], args) != 0)
+ _exit (1);
+#endif
+
+ return pid;
+}
+
+int
+__gnat_portable_wait (process_status)
+ int *process_status;
+{
+ int status = 0;
+ int pid = 0;
+
+#if defined (_WIN32)
+
+ pid = win32_wait (&status);
+
+#elif defined (__EMX__) || defined (MSDOS)
+ /* ??? See corresponding comment in portable_no_block_spawn. */
+
+#elif defined (__vxworks)
+ /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
+ return zero. */
+#else
+
+#ifdef VMS
+ /* Wait doesn't do the right thing on VMS */
+ pid = waitpid (-1, &status, 0);
+#else
+ pid = wait (&status);
+#endif
+ status = status & 0xffff;
+#endif
+
+ *process_status = status;
+ return pid;
+}
+
+void
+__gnat_os_exit (status)
+ int status;
+{
+#ifdef VMS
+ /* Exit without changing 0 to 1 */
+ __posix_exit (status);
+#else
+ exit (status);
+#endif
+}
+
+/* Locate a regular file, give a Path value */
+
+char *
+__gnat_locate_regular_file (file_name, path_val)
+ char *file_name;
+ char *path_val;
+{
+ char *ptr;
+
+ /* Handle absolute pathnames. */
+ for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
+ ;
+
+ if (*ptr != 0
+#if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
+ || isalpha (file_name [0]) && file_name [1] == ':'
+#endif
+ )
+ {
+ if (__gnat_is_regular_file (file_name))
+ return xstrdup (file_name);
+
+ return 0;
+ }
+
+ if (path_val == 0)
+ return 0;
+
+ {
+ /* The result has to be smaller than path_val + file_name. */
+ char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
+
+ for (;;)
+ {
+ for (; *path_val == PATH_SEPARATOR; path_val++)
+ ;
+
+ if (*path_val == 0)
+ return 0;
+
+ for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
+ *ptr++ = *path_val++;
+
+ ptr--;
+ if (*ptr != '/' && *ptr != DIR_SEPARATOR)
+ *++ptr = DIR_SEPARATOR;
+
+ strcpy (++ptr, file_name);
+
+ if (__gnat_is_regular_file (file_path))
+ return xstrdup (file_path);
+ }
+ }
+
+ return 0;
+}
+
+
+/* Locate an executable given a Path argument. This routine is only used by
+ gnatbl and should not be used otherwise. Use locate_exec_on_path
+ instead. */
+
+char *
+__gnat_locate_exec (exec_name, path_val)
+ char *exec_name;
+ char *path_val;
+{
+ if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
+ {
+ char *full_exec_name
+ = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
+
+ strcpy (full_exec_name, exec_name);
+ strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
+ return __gnat_locate_regular_file (full_exec_name, path_val);
+ }
+ else
+ return __gnat_locate_regular_file (exec_name, path_val);
+}
+
+/* Locate an executable using the Systems default PATH */
+
+char *
+__gnat_locate_exec_on_path (exec_name)
+ char *exec_name;
+{
+#ifdef VMS
+ char *path_val = "/VAXC$PATH";
+#else
+ char *path_val = getenv ("PATH");
+#endif
+ char *apath_val = alloca (strlen (path_val) + 1);
+
+ strcpy (apath_val, path_val);
+ return __gnat_locate_exec (exec_name, apath_val);
+}
+
+#ifdef VMS
+
+/* These functions are used to translate to and from VMS and Unix syntax
+ file, directory and path specifications. */
+
+#define MAXNAMES 256
+#define NEW_CANONICAL_FILELIST_INCREMENT 64
+
+static char new_canonical_dirspec [255];
+static char new_canonical_filespec [255];
+static char new_canonical_pathspec [MAXNAMES*255];
+static unsigned new_canonical_filelist_index;
+static unsigned new_canonical_filelist_in_use;
+static unsigned new_canonical_filelist_allocated;
+static char **new_canonical_filelist;
+static char new_host_pathspec [MAXNAMES*255];
+static char new_host_dirspec [255];
+static char new_host_filespec [255];
+
+/* Routine is called repeatedly by decc$from_vms via
+ __gnat_to_canonical_file_list_init until it returns 0 or the expansion
+ runs out. */
+
+static int
+wildcard_translate_unix (name)
+ char *name;
+{
+ char *ver;
+ char buff [256];
+
+ strcpy (buff, name);
+ ver = strrchr (buff, '.');
+
+ /* Chop off the version */
+ if (ver)
+ *ver = 0;
+
+ /* Dynamically extend the allocation by the increment */
+ if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
+ {
+ new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
+ new_canonical_filelist = (char **) realloc
+ (new_canonical_filelist,
+ new_canonical_filelist_allocated * sizeof (char *));
+ }
+
+ new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
+
+ return 1;
+}
+
+/* Translate a wildcard VMS file spec into a list of Unix file
+ specs. First do full translation and copy the results into a list (_init),
+ then return them one at a time (_next). If onlydirs set, only expand
+ directory files. */
+
+int
+__gnat_to_canonical_file_list_init (filespec, onlydirs)
+ char *filespec;
+ int onlydirs;
+{
+ int len;
+ char buff [256];
+
+ len = strlen (filespec);
+ strcpy (buff, filespec);
+
+ /* Only look for directories */
+ if (onlydirs && !strstr (&buff [len-5], "*.dir"))
+ strcat (buff, "*.dir");
+
+ decc$from_vms (buff, wildcard_translate_unix, 1);
+
+ /* Remove the .dir extension */
+ if (onlydirs)
+ {
+ int i;
+ char *ext;
+
+ for (i = 0; i < new_canonical_filelist_in_use; i++)
+ {
+ ext = strstr (new_canonical_filelist [i], ".dir");
+ if (ext)
+ *ext = 0;
+ }
+ }
+
+ return new_canonical_filelist_in_use;
+}
+
+/* Return the next filespec in the list */
+
+char *
+__gnat_to_canonical_file_list_next ()
+{
+ return new_canonical_filelist [new_canonical_filelist_index++];
+}
+
+/* Free up storage used in the wildcard expansion */
+
+void
+__gnat_to_canonical_file_list_free ()
+{
+ int i;
+
+ for (i = 0; i < new_canonical_filelist_in_use; i++)
+ free (new_canonical_filelist [i]);
+
+ free (new_canonical_filelist);
+
+ new_canonical_filelist_in_use = 0;
+ new_canonical_filelist_allocated = 0;
+ new_canonical_filelist_index = 0;
+ new_canonical_filelist = 0;
+}
+
+/* Translate a VMS syntax directory specification in to Unix syntax.
+ If prefixflag is set, append an underscore "/". If no indicators
+ of VMS syntax found, return input string. Also translate a dirname
+ that contains no slashes, in case it's a logical name. */
+
+char *
+__gnat_to_canonical_dir_spec (dirspec,prefixflag)
+ char *dirspec;
+ int prefixflag;
+{
+ int len;
+
+ strcpy (new_canonical_dirspec, "");
+ if (strlen (dirspec))
+ {
+ char *dirspec1;
+
+ if (strchr (dirspec, ']') || strchr (dirspec, ':'))
+ strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec));
+ else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
+ strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec1));
+ else
+ strcpy (new_canonical_dirspec, dirspec);
+ }
+
+ len = strlen (new_canonical_dirspec);
+ if (prefixflag && new_canonical_dirspec [len-1] != '/')
+ strcat (new_canonical_dirspec, "/");
+
+ return new_canonical_dirspec;
+
+}
+
+/* Translate a VMS syntax file specification into Unix syntax.
+ If no indicators of VMS syntax found, return input string. */
+
+char *
+__gnat_to_canonical_file_spec (filespec)
+ char *filespec;
+{
+ strcpy (new_canonical_filespec, "");
+ if (strchr (filespec, ']') || strchr (filespec, ':'))
+ strcpy (new_canonical_filespec, (char *) decc$translate_vms (filespec));
+ else
+ strcpy (new_canonical_filespec, filespec);
+
+ return new_canonical_filespec;
+}
+
+/* Translate a VMS syntax path specification into Unix syntax.
+ If no indicators of VMS syntax found, return input string. */
+
+char *
+__gnat_to_canonical_path_spec (pathspec)
+ char *pathspec;
+{
+ char *curr, *next, buff [256];
+
+ if (pathspec == 0)
+ return pathspec;
+
+ /* If there are /'s, assume it's a Unix path spec and return */
+ if (strchr (pathspec, '/'))
+ return pathspec;
+
+ new_canonical_pathspec [0] = 0;
+ curr = pathspec;
+
+ for (;;)
+ {
+ next = strchr (curr, ',');
+ if (next == 0)
+ next = strchr (curr, 0);
+
+ strncpy (buff, curr, next - curr);
+ buff [next - curr] = 0;
+
+ /* Check for wildcards and expand if present */
+ if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
+ {
+ int i, dirs;
+
+ dirs = __gnat_to_canonical_file_list_init (buff, 1);
+ for (i = 0; i < dirs; i++)
+ {
+ char *next_dir;
+
+ next_dir = __gnat_to_canonical_file_list_next ();
+ strcat (new_canonical_pathspec, next_dir);
+
+ /* Don't append the separator after the last expansion */
+ if (i+1 < dirs)
+ strcat (new_canonical_pathspec, ":");
+ }
+
+ __gnat_to_canonical_file_list_free ();
+ }
+ else
+ strcat (new_canonical_pathspec,
+ __gnat_to_canonical_dir_spec (buff, 0));
+
+ if (*next == 0)
+ break;
+
+ strcat (new_canonical_pathspec, ":");
+ curr = next + 1;
+ }
+
+ return new_canonical_pathspec;
+}
+
+static char filename_buff [256];
+
+static int
+translate_unix (name, type)
+ char *name;
+ int type;
+{
+ strcpy (filename_buff, name);
+ return 0;
+}
+
+/* Translate a Unix syntax path spec into a VMS style (comma separated
+ list of directories. Only used in this file so make it static */
+
+static char *
+to_host_path_spec (pathspec)
+ char *pathspec;
+{
+ char *curr, *next, buff [256];
+
+ if (pathspec == 0)
+ return pathspec;
+
+ /* Can't very well test for colons, since that's the Unix separator! */
+ if (strchr (pathspec, ']') || strchr (pathspec, ','))
+ return pathspec;
+
+ new_host_pathspec [0] = 0;
+ curr = pathspec;
+
+ for (;;)
+ {
+ next = strchr (curr, ':');
+ if (next == 0)
+ next = strchr (curr, 0);
+
+ strncpy (buff, curr, next - curr);
+ buff [next - curr] = 0;
+
+ strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0));
+ if (*next == 0)
+ break;
+ strcat (new_host_pathspec, ",");
+ curr = next + 1;
+ }
+
+ return new_host_pathspec;
+}
+
+/* Translate a Unix syntax directory specification into VMS syntax.
+ The prefixflag has no effect, but is kept for symmetry with
+ to_canonical_dir_spec.
+ If indicators of VMS syntax found, return input string. */
+
+char *
+__gnat_to_host_dir_spec (dirspec, prefixflag)
+ char *dirspec;
+ int prefixflag;
+{
+ int len = strlen (dirspec);
+
+ strcpy (new_host_dirspec, dirspec);
+
+ if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
+ return new_host_dirspec;
+
+ while (len > 1 && new_host_dirspec [len-1] == '/')
+ {
+ new_host_dirspec [len-1] = 0;
+ len--;
+ }
+
+ decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
+ strcpy (new_host_dirspec, filename_buff);
+
+ return new_host_dirspec;
+
+}
+
+/* Translate a Unix syntax file specification into VMS syntax.
+ If indicators of VMS syntax found, return input string. */
+
+char *
+__gnat_to_host_file_spec (filespec)
+ char *filespec;
+{
+ strcpy (new_host_filespec, "");
+ if (strchr (filespec, ']') || strchr (filespec, ':'))
+ strcpy (new_host_filespec, filespec);
+ else
+ {
+ decc$to_vms (filespec, translate_unix, 1, 1);
+ strcpy (new_host_filespec, filename_buff);
+ }
+
+ return new_host_filespec;
+}
+
+void
+__gnat_adjust_os_resource_limits ()
+{
+ SYS$ADJWSL (131072, 0);
+}
+
+#else
+
+/* Dummy functions for Osint import for non-VMS systems */
+
+int
+__gnat_to_canonical_file_list_init (dirspec, onlydirs)
+ char *dirspec ATTRIBUTE_UNUSED;
+ int onlydirs ATTRIBUTE_UNUSED;
+{
+ return 0;
+}
+
+char *
+__gnat_to_canonical_file_list_next ()
+{
+ return (char *) "";
+}
+
+void
+__gnat_to_canonical_file_list_free ()
+{
+}
+
+char *
+__gnat_to_canonical_dir_spec (dirspec, prefixflag)
+ char *dirspec;
+ int prefixflag ATTRIBUTE_UNUSED;
+{
+ return dirspec;
+}
+
+char *
+__gnat_to_canonical_file_spec (filespec)
+ char *filespec;
+{
+ return filespec;
+}
+
+char *
+__gnat_to_canonical_path_spec (pathspec)
+ char *pathspec;
+{
+ return pathspec;
+}
+
+char *
+__gnat_to_host_dir_spec (dirspec, prefixflag)
+ char *dirspec;
+ int prefixflag ATTRIBUTE_UNUSED;
+{
+ return dirspec;
+}
+
+char *
+__gnat_to_host_file_spec (filespec)
+ char *filespec;
+{
+ return filespec;
+}
+
+void
+__gnat_adjust_os_resource_limits ()
+{
+}
+
+#endif
+
+/* for EMX, we cannot include dummy in libgcc, since it is too difficult
+ to coordinate this with the EMX distribution. Consequently, we put the
+ definition of dummy() which is used for exception handling, here */
+
+#if defined (__EMX__)
+void __dummy () {}
+#endif
+
+#if defined (__mips_vxworks)
+int _flush_cache()
+{
+ CACHE_USER_FLUSH (0, ENTIRE_CACHE);
+}
+#endif
+
+#if defined (CROSS_COMPILE) \
+ || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
+ && ! defined (linux) \
+ && ! defined (sgi) \
+ && ! defined (hpux) \
+ && ! (defined (__alpha__) && defined (__osf__)) \
+ && ! defined (__MINGW32__))
+/* Dummy function to satisfy g-trasym.o.
+ Currently Solaris sparc, HP/UX, IRIX, Linux, Tru64 & Windows provide a
+ non-dummy version of this procedure in libaddr2line.a */
+
+void
+convert_addresses (addrs, n_addr, buf, len)
+ void *addrs ATTRIBUTE_UNUSED;
+ int n_addr ATTRIBUTE_UNUSED;
+ void *buf ATTRIBUTE_UNUSED;
+ int *len;
+{
+ *len = 0;
+}
+#endif
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A D A I N T *
+ * *
+ * $Revision: 1.4 $
+ * *
+ * C Header File *
+ * *
+ * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+#include <dirent.h>
+
+extern void __gnat_to_gm_time PARAMS ((time_t *, int *,
+ int *, int *,
+ int *, int *,
+ int *));
+extern int __gnat_get_maximum_file_name_length PARAMS ((void));
+extern char __gnat_get_switch_character PARAMS ((void));
+extern int __gnat_get_switches_case_sensitive PARAMS ((void));
+extern int __gnat_get_file_names_case_sensitive PARAMS ((void));
+extern char __gnat_get_default_identifier_character_set PARAMS ((void));
+extern void __gnat_get_current_dir PARAMS ((char *, int *));
+extern void __gnat_get_object_suffix_ptr PARAMS ((int *,
+ const char **));
+extern void __gnat_get_executable_suffix_ptr PARAMS ((int *,
+ const char **));
+extern void __gnat_get_debuggable_suffix_ptr PARAMS ((int *,
+ const char **));
+extern int __gnat_readlink PARAMS ((char *, char *,
+ size_t));
+extern int __gnat_symlink PARAMS ((char *, char *));
+extern int __gnat_try_lock PARAMS ((char *, char *));
+extern int __gnat_open_new PARAMS ((char *, int));
+extern int __gnat_open_new_temp PARAMS ((char *, int));
+extern int __gnat_mkdir PARAMS ((char *));
+extern int __gnat_stat PARAMS ((char *,
+ struct stat *));
+extern int __gnat_open_read PARAMS ((char *, int));
+extern int __gnat_open_rw PARAMS ((char *, int));
+extern int __gnat_open_create PARAMS ((char *, int));
+extern int __gnat_open_append PARAMS ((char *, int));
+extern long __gnat_file_length PARAMS ((int));
+extern void __gnat_tmp_name PARAMS ((char *));
+extern char *__gnat_readdir PARAMS ((DIR *, char*));
+extern int __gnat_readdir_is_thread_safe PARAMS ((void));
+extern time_t __gnat_file_time_name PARAMS ((char *));
+extern time_t __gnat_file_time_fd PARAMS ((int));
+extern void __gnat_get_env_value_ptr PARAMS ((char *, int *,
+ char **));
+extern int __gnat_file_exists PARAMS ((char *));
+extern int __gnat_is_regular_file PARAMS ((char *));
+extern int __gnat_is_absolute_path PARAMS ((char *));
+extern int __gnat_is_directory PARAMS ((char *));
+extern int __gnat_is_writable_file PARAMS ((char *));
+extern int __gnat_portable_spawn PARAMS ((char *[]));
+extern int __gnat_portable_no_block_spawn PARAMS ((char *[]));
+extern int __gnat_portable_wait PARAMS ((int *));
+extern char *__gnat_locate_exec PARAMS ((char *, char *));
+extern char *__gnat_locate_exec_on_path PARAMS ((char *));
+extern char *__gnat_locate_regular_file PARAMS ((char *, char *));
+extern void __gnat_maybe_glob_args PARAMS ((int *, char ***));
+extern void __gnat_os_exit PARAMS ((int));
+extern void __gnat_set_env_value PARAMS ((char *, char *));
+extern char *__gnat_get_libraries_from_registry PARAMS ((void));
+extern int __gnat_to_canonical_file_list_init PARAMS ((char *, int));
+extern char *__gnat_to_canonical_file_list_next PARAMS ((void));
+extern void __gnat_to_canonical_file_list_free PARAMS ((void));
+extern char *__gnat_to_canonical_dir_spec PARAMS ((char *, int));
+extern char *__gnat_to_canonical_file_spec PARAMS ((char *));
+extern char *__gnat_to_host_dir_spec PARAMS ((char *, int));
+extern char *__gnat_to_host_file_spec PARAMS ((char *));
+extern char *__gnat_to_canonical_path_spec PARAMS ((char *));
+extern void __gnat_adjust_os_resource_limits PARAMS ((void));
+
+extern int __gnat_feof PARAMS ((FILE *));
+extern int __gnat_ferror PARAMS ((FILE *));
+extern int __gnat_fileno PARAMS ((FILE *));
+extern int __gnat_is_regular_file_fd PARAMS ((int));
+extern FILE *__gnat_constant_stderr PARAMS ((void));
+extern FILE *__gnat_constant_stdin PARAMS ((void));
+extern FILE *__gnat_constant_stdout PARAMS ((void));
+extern char *__gnat_full_name PARAMS ((char *, char *));
+
+extern int __gnat_arg_count PARAMS ((void));
+extern int __gnat_len_arg PARAMS ((int));
+extern void __gnat_fill_arg PARAMS ((char *, int));
+extern int __gnat_env_count PARAMS ((void));
+extern int __gnat_len_env PARAMS ((int));
+extern void __gnat_fill_env PARAMS ((char *, int));
+
+/* Routines for interface to scanf and printf functions for integer values */
+
+extern int get_int PARAMS ((void));
+extern void put_int PARAMS ((int));
+extern void put_int_stderr PARAMS ((int));
+extern int get_char PARAMS ((void));
+extern void put_char PARAMS ((int));
+extern void put_char_stderr PARAMS ((int));
+extern char *mktemp PARAMS ((char *));
+
+extern void __gnat_set_exit_status PARAMS ((int));
+
+extern int __gnat_expect_fork PARAMS ((void));
+extern void __gnat_expect_portable_execvp PARAMS ((char *, char *[]));
+extern int __gnat_pipe PARAMS ((int *));
+extern int __gnat_expect_poll PARAMS ((int *, int, int,
+ int *));
+extern void __gnat_set_binary_mode PARAMS ((FILE *));
+extern void __gnat_set_text_mode PARAMS ((FILE *));
+extern char *__gnat_ttyname PARAMS ((int));
+
+#ifdef IN_RTS
+/* Portable definition of strdup, which is not available on all systems. */
+#define xstrdup(S) strcpy ((char *) malloc (strlen (S) + 1), S)
+#endif
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L I . U T I L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Binderr; use Binderr;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+
+package body ALI.Util is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Accumulate_Checksum (C : Character; Csum : in out Word);
+ pragma Inline (Accumulate_Checksum);
+ -- This routine accumulates the checksum given character C. During the
+ -- scanning of a source file, this routine is called with every character
+ -- in the source, excluding blanks, and all control characters (except
+ -- that ESC is included in the checksum). Upper case letters not in string
+ -- literals are folded by the caller. See Sinput spec for the documentation
+ -- of the checksum algorithm. Note: checksum values are only used if we
+ -- generate code, so it is not necessary to worry about making the right
+ -- sequence of calls in any error situation.
+
+ -------------------------
+ -- Accumulate_Checksum --
+ -------------------------
+
+ procedure Accumulate_Checksum (C : Character; Csum : in out Word) is
+ begin
+ Csum := Csum + Csum + Character'Pos (C);
+
+ if Csum > 16#8000_0000# then
+ Csum := (Csum + 1) and 16#7FFF_FFFF#;
+ end if;
+ end Accumulate_Checksum;
+
+ -----------------------
+ -- Get_File_Checksum --
+ -----------------------
+
+ function Get_File_Checksum (Fname : Name_Id) return Word is
+ Src : Source_Buffer_Ptr;
+ Hi : Source_Ptr;
+ Csum : Word;
+ Ptr : Source_Ptr;
+
+ Bad : exception;
+ -- Raised if file not found, or file format error
+
+ use ASCII;
+ -- Make control characters visible
+
+ procedure Free_Source;
+ -- Free source file buffer
+
+ procedure Free_Source is
+ procedure free (Arg : Source_Buffer_Ptr);
+ pragma Import (C, free, "free");
+
+ begin
+ free (Src);
+ end Free_Source;
+
+ -- Start of processing for Get_File_Checksum
+
+ begin
+ Read_Source_File (Fname, 0, Hi, Src);
+
+ -- If we cannot find the file, then return an impossible checksum,
+ -- impossible becaues checksums have the high order bit zero, so
+ -- that checksums do not match.
+
+ if Src = null then
+ raise Bad;
+ end if;
+
+ Csum := 0;
+ Ptr := 0;
+
+ loop
+ case Src (Ptr) is
+
+ -- Spaces and formatting information are ignored in checksum
+
+ when ' ' | CR | LF | VT | FF | HT =>
+ Ptr := Ptr + 1;
+
+ -- EOF is ignored unless it is the last character
+
+ when EOF =>
+ if Ptr = Hi then
+ Free_Source;
+ return Csum;
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- Non-blank characters that are included in the checksum
+
+ when '#' | '&' | '*' | ':' | '(' | ',' | '.' | '=' | '>' |
+ '<' | ')' | '/' | ';' | '|' | '!' | '+' | '_' |
+ '0' .. '9' | 'a' .. 'z'
+ =>
+ Accumulate_Checksum (Src (Ptr), Csum);
+ Ptr := Ptr + 1;
+
+ -- Upper case letters, fold to lower case
+
+ when 'A' .. 'Z' =>
+ Accumulate_Checksum
+ (Character'Val (Character'Pos (Src (Ptr)) + 32), Csum);
+ Ptr := Ptr + 1;
+
+ -- Left bracket, really should do wide character thing here,
+ -- but for now, don't bother.
+
+ when '[' =>
+ raise Bad;
+
+ -- Minus, could be comment
+
+ when '-' =>
+ if Src (Ptr + 1) = '-' then
+ Ptr := Ptr + 2;
+
+ while Src (Ptr) >= ' ' or else Src (Ptr) = HT loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ else
+ Accumulate_Checksum ('-', Csum);
+ Ptr := Ptr + 1;
+ end if;
+
+ -- String delimited by double quote
+
+ when '"' =>
+ Accumulate_Checksum ('"', Csum);
+
+ loop
+ Ptr := Ptr + 1;
+ exit when Src (Ptr) = '"';
+
+ if Src (Ptr) < ' ' then
+ raise Bad;
+ end if;
+
+ Accumulate_Checksum (Src (Ptr), Csum);
+ end loop;
+
+ Accumulate_Checksum ('"', Csum);
+ Ptr := Ptr + 1;
+
+ -- String delimited by percent
+
+ when '%' =>
+ Accumulate_Checksum ('%', Csum);
+
+ loop
+ Ptr := Ptr + 1;
+ exit when Src (Ptr) = '%';
+
+ if Src (Ptr) < ' ' then
+ raise Bad;
+ end if;
+
+ Accumulate_Checksum (Src (Ptr), Csum);
+ end loop;
+
+ Accumulate_Checksum ('%', Csum);
+ Ptr := Ptr + 1;
+
+ -- Quote, could be character constant
+
+ when ''' =>
+ Accumulate_Checksum (''', Csum);
+
+ if Src (Ptr + 2) = ''' then
+ Accumulate_Checksum (Src (Ptr + 1), Csum);
+ Accumulate_Checksum (''', Csum);
+ Ptr := Ptr + 3;
+
+ -- Otherwise assume attribute char. We should deal with wide
+ -- character cases here, but that's hard, so forget it.
+
+ else
+ Ptr := Ptr + 1;
+ end if;
+
+ -- Upper half character, more to be done here, we should worry
+ -- about folding Latin-1, folding other character sets, and
+ -- dealing with the nasty case of upper half wide encoding.
+
+ when Upper_Half_Character =>
+ Accumulate_Checksum (Src (Ptr), Csum);
+ Ptr := Ptr + 1;
+
+ -- Escape character, we should do the wide character thing here,
+ -- but for now, do not bother.
+
+ when ESC =>
+ raise Bad;
+
+ -- Invalid control characters
+
+ when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
+ SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
+ EM | FS | GS | RS | US | DEL
+ =>
+ raise Bad;
+
+ -- Invalid graphic characters
+
+ when '$' | '?' | '@' | '`' | '\' |
+ '^' | '~' | ']' | '{' | '}'
+ =>
+ raise Bad;
+
+ end case;
+ end loop;
+
+ exception
+ when Bad =>
+ Free_Source;
+ return 16#FFFF_FFFF#;
+
+ end Get_File_Checksum;
+
+ ---------------------------
+ -- Initialize_ALI_Source --
+ ---------------------------
+
+ procedure Initialize_ALI_Source is
+ begin
+ -- When (re)initializing ALI data structures the ALI user expects to
+ -- get a fresh set of data structures. Thus we first need to erase the
+ -- marks put in the name table by the previous set of ALI routine calls.
+ -- This loop is empty and harmless the first time in.
+
+ for J in Source.First .. Source.Last loop
+ Set_Name_Table_Info (Source.Table (J).Sfile, 0);
+ Source.Table (J).Source_Found := False;
+ end loop;
+
+ Source.Init;
+ end Initialize_ALI_Source;
+
+ --------------
+ -- Read_ALI --
+ --------------
+
+ procedure Read_ALI (Id : ALI_Id) is
+ Afile : File_Name_Type;
+ Text : Text_Buffer_Ptr;
+ Idread : ALI_Id;
+
+ begin
+ for I in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop
+ for J in Units.Table (I).First_With .. Units.Table (I).Last_With loop
+
+ Afile := Withs.Table (J).Afile;
+
+ -- Only process if not a generic (Afile /= No_File) and if
+ -- file has not been processed already.
+
+ if Afile /= No_File and then Get_Name_Table_Info (Afile) = 0 then
+
+ Text := Read_Library_Info (Afile);
+
+ if Text = null then
+ Error_Msg_Name_1 := Afile;
+ Error_Msg_Name_2 := Withs.Table (J).Sfile;
+ Error_Msg ("% not found, % must be compiled");
+ Set_Name_Table_Info (Afile, Int (No_Unit_Id));
+ return;
+ end if;
+
+ Idread :=
+ Scan_ALI
+ (F => Afile,
+ T => Text,
+ Ignore_ED => Force_RM_Elaboration_Order,
+ Err => False);
+
+ Free (Text);
+
+ if ALIs.Table (Idread).Compile_Errors then
+ Error_Msg_Name_1 := Withs.Table (J).Sfile;
+ Error_Msg ("% had errors, must be fixed, and recompiled");
+ Set_Name_Table_Info (Afile, Int (No_Unit_Id));
+
+ elsif ALIs.Table (Idread).No_Object then
+ Error_Msg_Name_1 := Withs.Table (J).Sfile;
+ Error_Msg ("% must be recompiled");
+ Set_Name_Table_Info (Afile, Int (No_Unit_Id));
+ end if;
+
+ -- Recurse to get new dependents
+
+ Read_ALI (Idread);
+ end if;
+ end loop;
+ end loop;
+
+ end Read_ALI;
+
+ ----------------------
+ -- Set_Source_Table --
+ ----------------------
+
+ procedure Set_Source_Table (A : ALI_Id) is
+ F : File_Name_Type;
+ S : Source_Id;
+ Stamp : Time_Stamp_Type;
+
+ begin
+ Sdep_Loop : for D in
+ ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
+ loop
+ F := Sdep.Table (D).Sfile;
+
+ -- If this is the first time we are seeing this source file,
+ -- then make a new entry in the source table.
+
+ if Get_Name_Table_Info (F) = 0 then
+ Source.Increment_Last;
+ S := Source.Last;
+ Set_Name_Table_Info (F, Int (S));
+ Source.Table (S).Sfile := F;
+ Source.Table (S).All_Timestamps_Match := True;
+
+ -- Initialize checksum fields
+
+ Source.Table (S).Checksum := Sdep.Table (D).Checksum;
+ Source.Table (S).All_Checksums_Match := True;
+
+ -- In check source files mode, try to get time stamp from file
+
+ if Opt.Check_Source_Files then
+ Stamp := Source_File_Stamp (F);
+
+ -- If we got the stamp, then set the stamp in the source
+ -- table entry and mark it as set from the source so that
+ -- it does not get subsequently changed.
+
+ if Stamp (Stamp'First) /= ' ' then
+ Source.Table (S).Stamp := Stamp;
+ Source.Table (S).Source_Found := True;
+
+ -- If we could not find the file, then the stamp is set
+ -- from the dependency table entry (to be possibly reset
+ -- if we find a later stamp in subsequent processing)
+
+ else
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ Source.Table (S).Source_Found := False;
+
+ -- In All_Sources mode, flag error of file not found
+
+ if Opt.All_Sources then
+ Error_Msg_Name_1 := F;
+ Error_Msg ("cannot locate %");
+ end if;
+ end if;
+
+ -- First time for this source file, but Check_Source_Files
+ -- is off, so simply initialize the stamp from the Sdep entry
+
+ else
+ Source.Table (S).Source_Found := False;
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ end if;
+
+ -- Here if this is not the first time for this source file,
+ -- so that the source table entry is already constructed.
+
+ else
+ S := Source_Id (Get_Name_Table_Info (F));
+
+ -- Update checksum flag
+
+ if Sdep.Table (D).Checksum /= Source.Table (S).Checksum then
+ Source.Table (S).All_Checksums_Match := False;
+ end if;
+
+ -- Check for time stamp mismatch
+
+ if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then
+ Source.Table (S).All_Timestamps_Match := False;
+
+ -- When we have a time stamp mismatch, we go look for the
+ -- source file even if Check_Source_Files is false, since
+ -- if we find it, then we can use it to resolve which of the
+ -- two timestamps in the ALI files is likely to be correct.
+
+ if not Check_Source_Files then
+ Stamp := Source_File_Stamp (F);
+
+ if Stamp (Stamp'First) /= ' ' then
+ Source.Table (S).Stamp := Stamp;
+ Source.Table (S).Source_Found := True;
+ end if;
+ end if;
+
+ -- If the stamp in the source table entry was set from the
+ -- source file, then we do not change it (the stamp in the
+ -- source file is always taken as the "right" one).
+
+ if Source.Table (S).Source_Found then
+ null;
+
+ -- Otherwise, we have no source file available, so we guess
+ -- that the later of the two timestamps is the right one.
+ -- Note that this guess only affects which error messages
+ -- are issued later on, not correct functionality.
+
+ else
+ if Sdep.Table (D).Stamp > Source.Table (S).Stamp then
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Set the checksum value in the source table
+
+ S := Source_Id (Get_Name_Table_Info (F));
+ Source.Table (S).Checksum := Sdep.Table (D).Checksum;
+
+ end loop Sdep_Loop;
+
+ end Set_Source_Table;
+
+ ----------------------
+ -- Set_Source_Table --
+ ----------------------
+
+ procedure Set_Source_Table is
+ begin
+ for A in ALIs.First .. ALIs.Last loop
+ Set_Source_Table (A);
+ end loop;
+
+ end Set_Source_Table;
+
+ -------------------------
+ -- Time_Stamp_Mismatch --
+ -------------------------
+
+ function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type is
+ Src : Source_Id;
+ -- Source file Id for the current Sdep entry
+
+ begin
+ for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
+ Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
+
+ if Opt.Minimal_Recompilation
+ and then Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
+ then
+
+ -- If minimal recompilation is in action, replace the stamp
+ -- of the source file in the table if checksums match.
+
+ -- ??? It is probably worth updating the ALI file with a new
+ -- field to avoid recomputing it each time.
+
+ if Get_File_Checksum (Sdep.Table (D).Sfile) =
+ Source.Table (Src).Checksum
+ then
+ Sdep.Table (D).Stamp := Source.Table (Src).Stamp;
+ end if;
+
+ end if;
+
+ if not Source.Table (Src).Source_Found
+ or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
+ then
+ return Source.Table (Src).Sfile;
+ end if;
+ end loop;
+
+ return No_File;
+
+ end Time_Stamp_Mismatch;
+
+end ALI.Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L I . U T I L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This child unit provides utility data structures and procedures used
+-- for manipulation of ALI data by the gnatbind and gnatmake.
+
+package ALI.Util is
+
+ -----------------------
+ -- Source File Table --
+ -----------------------
+
+ -- A source file table entry is built for every source file that is
+ -- in the source dependency table of any of the ALI files that make
+ -- up the current program.
+
+ No_Source_Id : constant Source_Id := Source_Id'First;
+ -- Special value indicating no Source table entry
+
+ First_Source_Entry : constant Source_Id := No_Source_Id + 1;
+ -- Id of first actual entry in table
+
+ type Source_Record is record
+
+ Sfile : File_Name_Type;
+ -- Name of source file
+
+ Stamp : Time_Stamp_Type;
+ -- Time stamp value. If Check_Source_Files is set and the source
+ -- file is located, then Stamp is set from the source file. Otherwise
+ -- Stamp is set from the latest stamp value found in any of the
+ -- ALI files for the current program.
+
+ Source_Found : Boolean;
+ -- This flag is set to True if the corresponding source file was
+ -- located and the Stamp value was set from the actual source file.
+ -- It is always false if Check_Source_Files is not set.
+
+ All_Timestamps_Match : Boolean;
+ -- This flag is set only if all files referencing this source file
+ -- have a matching time stamp, and also, if Source_Found is True,
+ -- then the stamp of the source file also matches. If this flag is
+ -- True, then checksums for this file are never referenced. We only
+ -- use checksums if there are time stamp mismatches.
+
+ All_Checksums_Match : Boolean;
+ -- This flag is set only if all files referencing this source file
+ -- have checksums, and if all these checksums match. If this flag
+ -- is set to True, then the binder will ignore a timestamp mismatch.
+ -- An absent checksum causes this flag to be set False, and a mismatch
+ -- of checksums also causes it to be set False. The checksum of the
+ -- actual source file (if Source_Found is True) is included only if
+ -- All_Timestamps_Match is False (since checksums are only interesting
+ -- if we have time stamp mismatches, and we want to avoid computing the
+ -- checksum of the source file if it is not needed.)
+
+ Checksum : Word;
+ -- If no dependency line has a checksum for this source file (i.e. the
+ -- corresponding entries in the source dependency records all have the
+ -- Checksum_Present flag set False), then this field is undefined. If
+ -- at least one dependency entry has a checksum present, then this
+ -- field contains one of the possible checksum values that has been
+ -- seen. This is used to set All_Checksums_Match properly.
+
+ end record;
+
+ package Source is new Table.Table (
+ Table_Component_Type => Source_Record,
+ Table_Index_Type => Source_Id,
+ Table_Low_Bound => First_Source_Entry,
+ Table_Initial => 1000,
+ Table_Increment => 200,
+ Table_Name => "Source");
+
+ procedure Initialize_ALI_Source;
+ -- Initialize Source table
+
+ --------------------------------------------------
+ -- Subprograms for Manipulating ALI Information --
+ --------------------------------------------------
+
+ procedure Read_ALI (Id : ALI_Id);
+ -- Process an ALI file which has been read and scanned by looping
+ -- through all withed units in the ALI file; checking if they have
+ -- been processed; and for each that hasn't, reading, scanning, and
+ -- recursively processing.
+
+ procedure Set_Source_Table (A : ALI_Id);
+ -- Build source table entry corresponding to the ALI file whose id is A.
+
+ procedure Set_Source_Table;
+ -- Build the entire source table.
+
+ function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type;
+ -- Looks in the Source_Table and checks time stamp mismatches between
+ -- the sources there and the sources in the Sdep section of ali file whose
+ -- id is A. If no time stamp mismatches are found No_File is returned.
+ -- Otherwise return the first file for which there is a mismatch.
+ -- Note that in check source files mode (Check_Source_Files = True), the
+ -- time stamp in the Source_Table should be the actual time stamp of the
+ -- source files. In minimal recompilation mode (Minimal_Recompilation set
+ -- to True, no mismatch is found if the file's timestamp has not changed.
+
+ --------------------------------------------
+ -- Subprograms for manipulating checksums --
+ --------------------------------------------
+
+ function Get_File_Checksum (Fname : Name_Id) return Word;
+ -- Compute checksum for the given file. As far as possible, this circuit
+ -- computes exactly the same value computed by the compiler, but it does
+ -- not matter if it gets it wrong in marginal cases, since the only result
+ -- is to miss some smart recompilation cases, correct functioning is not
+ -- affecte by a mis-computation. Returns an impossible checksum value,
+ -- with the upper bit set, if the file is missing or has an error.
+
+end ALI.Util;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L I --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.124 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Butil; use Butil;
+with Debug; use Debug;
+with Fname; use Fname;
+with Namet; use Namet;
+with Osint; use Osint;
+with Output; use Output;
+
+package body ALI is
+
+ use ASCII;
+ -- Make control characters visible
+
+ --------------------
+ -- Initialize_ALI --
+ --------------------
+
+ procedure Initialize_ALI is
+ begin
+ -- When (re)initializing ALI data structures the ALI user expects to
+ -- get a fresh set of data structures. Thus we first need to erase the
+ -- marks put in the name table by the previous set of ALI routine calls.
+ -- This loop is empty and harmless the first time in.
+
+ for J in ALIs.First .. ALIs.Last loop
+ Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
+ end loop;
+
+ ALIs.Init;
+ Units.Init;
+ Withs.Init;
+ Sdep.Init;
+ Linker_Options.Init;
+ Xref_Section.Init;
+ Xref_Entity.Init;
+ Xref.Init;
+ Version_Ref.Reset;
+
+ -- Add dummy zero'th item in Linker_Options for the sort function
+
+ Linker_Options.Increment_Last;
+
+ -- Initialize global variables recording cumulative options in all
+ -- ALI files that are read for a given processing run in gnatbind.
+
+ Dynamic_Elaboration_Checks_Specified := False;
+ Float_Format_Specified := ' ';
+ Locking_Policy_Specified := ' ';
+ No_Normalize_Scalars_Specified := False;
+ No_Object_Specified := False;
+ Normalize_Scalars_Specified := False;
+ No_Run_Time_Specified := False;
+ Queuing_Policy_Specified := ' ';
+ Static_Elaboration_Model_Used := False;
+ Task_Dispatching_Policy_Specified := ' ';
+ Unreserve_All_Interrupts_Specified := False;
+ Zero_Cost_Exceptions_Specified := False;
+
+ end Initialize_ALI;
+
+ --------------
+ -- Scan_ALI --
+ --------------
+
+ function Scan_ALI
+ (F : File_Name_Type;
+ T : Text_Buffer_Ptr;
+ Ignore_ED : Boolean;
+ Err : Boolean;
+ Read_Xref : Boolean := False)
+ return ALI_Id
+ is
+ P : Text_Ptr := T'First;
+ Line : Logical_Line_Number := 1;
+ Id : ALI_Id;
+ C : Character;
+ NS_Found : Boolean;
+ First_Arg : Arg_Id;
+
+ function At_Eol return Boolean;
+ -- Test if at end of line
+
+ function At_End_Of_Field return Boolean;
+ -- Test if at end of line, or if at blank or horizontal tab
+
+ procedure Check_At_End_Of_Field;
+ -- Check if we are at end of field, fatal error if not
+
+ procedure Checkc (C : Character);
+ -- Check next character is C. If so bump past it, if not fatal error
+
+ Bad_ALI_Format : exception;
+
+ procedure Fatal_Error;
+ -- Generate fatal error message for badly formatted ALI file if
+ -- Err is false, or raise Bad_ALI_Format if Err is True.
+
+ function Getc return Character;
+ -- Get next character, bumping P past the character obtained
+
+ function Get_Name (Lower : Boolean := False) return Name_Id;
+ -- Skip blanks, then scan out a name (name is left in Name_Buffer with
+ -- length in Name_Len, as well as being returned in Name_Id form). The
+ -- name is adjusted appropriately if it refers to a file that is to be
+ -- substituted by another name as a result of a configuration pragma.
+ -- If Lower is set to true then the Name_Buffer will be converted to
+ -- all lower case. This only happends for systems where file names are
+ -- not case sensitive, and ensures that gnatbind works correctly on
+ -- such systems, regardless of the case of the file name.
+
+ function Get_Nat return Nat;
+ -- Skip blanks, then scan out an unsigned integer value in Nat range
+
+ function Get_Stamp return Time_Stamp_Type;
+ -- Skip blanks, then scan out a time stamp
+
+ function Nextc return Character;
+ -- Return current character without modifying pointer P
+
+ procedure Skip_Eol;
+ -- Skip past end of line (fatal error if not at end of line)
+
+ procedure Skip_Space;
+ -- Skip past white space (blanks or horizontal tab)
+
+ ---------------------
+ -- At_End_Of_Field --
+ ---------------------
+
+ function At_End_Of_Field return Boolean is
+ begin
+ return Nextc <= ' ';
+ end At_End_Of_Field;
+
+ ------------
+ -- At_Eol --
+ ------------
+
+ function At_Eol return Boolean is
+ begin
+ return Nextc = EOF or else Nextc = CR or else Nextc = LF;
+ end At_Eol;
+
+ ---------------------------
+ -- Check_At_End_Of_Field --
+ ---------------------------
+
+ procedure Check_At_End_Of_Field is
+ begin
+ if not At_End_Of_Field then
+ Fatal_Error;
+ end if;
+ end Check_At_End_Of_Field;
+
+ ------------
+ -- Checkc --
+ ------------
+
+ procedure Checkc (C : Character) is
+ begin
+ if Nextc = C then
+ P := P + 1;
+ else
+ Fatal_Error;
+ end if;
+ end Checkc;
+
+ -----------------
+ -- Fatal_Error --
+ -----------------
+
+ procedure Fatal_Error is
+ Ptr1 : Text_Ptr;
+ Ptr2 : Text_Ptr;
+ Col : Int;
+
+ procedure Wchar (C : Character);
+ -- Write a single character, replacing horizontal tab by spaces
+
+ procedure Wchar (C : Character) is
+ begin
+ if C = HT then
+ loop
+ Wchar (' ');
+ exit when Col mod 8 = 0;
+ end loop;
+
+ else
+ Write_Char (C);
+ Col := Col + 1;
+ end if;
+ end Wchar;
+
+ -- Start of processing for Fatal_Error
+
+ begin
+ if Err then
+ raise Bad_ALI_Format;
+ end if;
+
+ Set_Standard_Error;
+ Write_Str ("fatal error: file ");
+ Write_Name (F);
+ Write_Str (" is incorrectly formatted");
+ Write_Eol;
+ Write_Str
+ ("make sure you are using consistent versions of gcc/gnatbind");
+ Write_Eol;
+
+ -- Find start of line
+
+ Ptr1 := P;
+
+ while Ptr1 > T'First
+ and then T (Ptr1 - 1) /= CR
+ and then T (Ptr1 - 1) /= LF
+ loop
+ Ptr1 := Ptr1 - 1;
+ end loop;
+
+ Write_Int (Int (Line));
+ Write_Str (". ");
+
+ if Line < 100 then
+ Write_Char (' ');
+ end if;
+
+ if Line < 10 then
+ Write_Char (' ');
+ end if;
+
+ Col := 0;
+ Ptr2 := Ptr1;
+
+ while Ptr2 < T'Last
+ and then T (Ptr2) /= CR
+ and then T (Ptr2) /= LF
+ loop
+ Wchar (T (Ptr2));
+ Ptr2 := Ptr2 + 1;
+ end loop;
+
+ Write_Eol;
+
+ Write_Str (" ");
+ Col := 0;
+
+ while Ptr1 < P loop
+ if T (Ptr1) = HT then
+ Wchar (HT);
+ else
+ Wchar (' ');
+ end if;
+
+ Ptr1 := Ptr1 + 1;
+ end loop;
+
+ Wchar ('|');
+ Write_Eol;
+
+ Exit_Program (E_Fatal);
+ end Fatal_Error;
+
+ --------------
+ -- Get_Name --
+ --------------
+
+ function Get_Name (Lower : Boolean := False) return Name_Id is
+ begin
+ Name_Len := 0;
+ Skip_Space;
+
+ if At_Eol then
+ Fatal_Error;
+ end if;
+
+ loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ exit when At_End_Of_Field;
+ end loop;
+
+ -- Convert file name to all lower case if file names are not case
+ -- sensitive. This ensures that we handle names in the canonical
+ -- lower case format, regardless of the actual case.
+
+ if Lower and not File_Names_Case_Sensitive then
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ end if;
+
+ return Name_Find;
+ end Get_Name;
+
+ -------------
+ -- Get_Nat --
+ -------------
+
+ function Get_Nat return Nat is
+ V : Nat;
+
+ begin
+ Skip_Space;
+
+ V := 0;
+
+ loop
+ V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
+ exit when At_End_Of_Field;
+ exit when Nextc < '0' or Nextc > '9';
+ end loop;
+
+ return V;
+ end Get_Nat;
+
+ ---------------
+ -- Get_Stamp --
+ ---------------
+
+ function Get_Stamp return Time_Stamp_Type is
+ T : Time_Stamp_Type;
+ Start : Integer;
+
+ begin
+ Skip_Space;
+
+ if At_Eol then
+ Fatal_Error;
+ end if;
+
+ -- Following reads old style time stamp missing first two digits
+
+ if Nextc in '7' .. '9' then
+ T (1) := '1';
+ T (2) := '9';
+ Start := 3;
+
+ -- Normal case of full year in time stamp
+
+ else
+ Start := 1;
+ end if;
+
+ for J in Start .. T'Last loop
+ T (J) := Getc;
+ end loop;
+
+ return T;
+ end Get_Stamp;
+
+ ----------
+ -- Getc --
+ ----------
+
+ function Getc return Character is
+ begin
+ if P = T'Last then
+ return EOF;
+ else
+ P := P + 1;
+ return T (P - 1);
+ end if;
+ end Getc;
+
+ -----------
+ -- Nextc --
+ -----------
+
+ function Nextc return Character is
+ begin
+ return T (P);
+ end Nextc;
+
+ --------------
+ -- Skip_Eol --
+ --------------
+
+ procedure Skip_Eol is
+ begin
+ Skip_Space;
+ if not At_Eol then Fatal_Error; end if;
+
+ -- Loop to skip past blank lines (first time through skips this EOL)
+
+ while Nextc < ' ' and then Nextc /= EOF loop
+ if Nextc = LF then
+ Line := Line + 1;
+ end if;
+
+ P := P + 1;
+ end loop;
+ end Skip_Eol;
+
+ ----------------
+ -- Skip_Space --
+ ----------------
+
+ procedure Skip_Space is
+ begin
+ while Nextc = ' ' or else Nextc = HT loop
+ P := P + 1;
+ end loop;
+ end Skip_Space;
+
+ --------------------------------------
+ -- Start of processing for Scan_ALI --
+ --------------------------------------
+
+ begin
+ ALIs.Increment_Last;
+ Id := ALIs.Last;
+ Set_Name_Table_Info (F, Int (Id));
+
+ ALIs.Table (Id) := (
+ Afile => F,
+ Compile_Errors => False,
+ First_Sdep => No_Sdep_Id,
+ First_Unit => No_Unit_Id,
+ Float_Format => 'I',
+ Last_Sdep => No_Sdep_Id,
+ Last_Unit => No_Unit_Id,
+ Locking_Policy => ' ',
+ Main_Priority => -1,
+ Main_Program => None,
+ No_Object => False,
+ No_Run_Time => False,
+ Normalize_Scalars => False,
+ Ofile_Full_Name => Full_Object_File_Name,
+ Queuing_Policy => ' ',
+ Restrictions => (others => ' '),
+ Sfile => No_Name,
+ Task_Dispatching_Policy => ' ',
+ Time_Slice_Value => -1,
+ WC_Encoding => '8',
+ Unit_Exception_Table => False,
+ Ver => (others => ' '),
+ Ver_Len => 0,
+ Zero_Cost_Exceptions => False);
+
+ -- Acquire library version
+
+ Checkc ('V');
+ Checkc (' ');
+ Skip_Space;
+ Checkc ('"');
+
+ for J in 1 .. Ver_Len_Max loop
+ C := Getc;
+ exit when C = '"';
+ ALIs.Table (Id).Ver (J) := C;
+ ALIs.Table (Id).Ver_Len := J;
+ end loop;
+
+ Skip_Eol;
+
+ -- Acquire main program line if present
+
+ C := Getc;
+
+ if C = 'M' then
+ Checkc (' ');
+ Skip_Space;
+
+ C := Getc;
+
+ if C = 'F' then
+ ALIs.Table (Id).Main_Program := Func;
+ elsif C = 'P' then
+ ALIs.Table (Id).Main_Program := Proc;
+ else
+ P := P - 1;
+ Fatal_Error;
+ end if;
+
+ Skip_Space;
+
+ if not At_Eol then
+ if Nextc < 'A' then
+ ALIs.Table (Id).Main_Priority := Get_Nat;
+ end if;
+
+ Skip_Space;
+
+ if Nextc = 'T' then
+ P := P + 1;
+ Checkc ('=');
+ ALIs.Table (Id).Time_Slice_Value := Get_Nat;
+ end if;
+
+ Skip_Space;
+
+ Checkc ('W');
+ Checkc ('=');
+ ALIs.Table (Id).WC_Encoding := Getc;
+ end if;
+
+ Skip_Eol;
+ C := Getc;
+
+ end if;
+
+ -- Acquire argument lines
+
+ First_Arg := Args.Last + 1;
+
+ Arg_Loop : while C = 'A' loop
+ Checkc (' ');
+ Name_Len := 0;
+
+ while not At_Eol loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
+
+ Args.Increment_Last;
+ Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Skip_Eol;
+ C := Getc;
+ end loop Arg_Loop;
+
+ -- Acquire P line, first set defaults
+
+ if C /= 'P' then
+ Fatal_Error;
+ end if;
+
+ NS_Found := False;
+
+ while not At_Eol loop
+ Checkc (' ');
+ Skip_Space;
+ C := Getc;
+
+ if C = 'C' then
+ Checkc ('E');
+ ALIs.Table (Id).Compile_Errors := True;
+
+ elsif C = 'F' then
+ Float_Format_Specified := Getc;
+ ALIs.Table (Id).Float_Format := Float_Format_Specified;
+
+ elsif C = 'L' then
+ Locking_Policy_Specified := Getc;
+ ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
+
+ elsif C = 'N' then
+ C := Getc;
+
+ if C = 'O' then
+ ALIs.Table (Id).No_Object := True;
+ No_Object_Specified := True;
+
+ elsif C = 'R' then
+ No_Run_Time_Specified := True;
+ ALIs.Table (Id).No_Run_Time := True;
+
+ elsif C = 'S' then
+ ALIs.Table (Id).Normalize_Scalars := True;
+ Normalize_Scalars_Specified := True;
+ NS_Found := True;
+
+ else
+ Fatal_Error;
+ end if;
+
+ elsif C = 'Q' then
+ Queuing_Policy_Specified := Getc;
+ ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
+
+ elsif C = 'T' then
+ Task_Dispatching_Policy_Specified := Getc;
+ ALIs.Table (Id).Task_Dispatching_Policy :=
+ Task_Dispatching_Policy_Specified;
+
+ elsif C = 'U' then
+ if Nextc = 'A' then
+ Unreserve_All_Interrupts_Specified := True;
+ C := Getc;
+
+ else
+ Checkc ('X');
+ ALIs.Table (Id).Unit_Exception_Table := True;
+ end if;
+
+ elsif C = 'Z' then
+ Checkc ('X');
+ ALIs.Table (Id).Zero_Cost_Exceptions := True;
+ Zero_Cost_Exceptions_Specified := True;
+
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ if not NS_Found then
+ No_Normalize_Scalars_Specified := True;
+ end if;
+
+ Skip_Eol;
+
+ -- Acquire restrictions line
+
+ if Getc /= 'R' then
+ Fatal_Error;
+
+ else
+ Checkc (' ');
+ Skip_Space;
+
+ for J in Partition_Restrictions loop
+ C := Getc;
+
+ if C = 'v' or else C = 'r' or else C = 'n' then
+ ALIs.Table (Id).Restrictions (J) := C;
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ if At_Eol then
+ Skip_Eol;
+ C := Getc;
+ else
+ Fatal_Error;
+ end if;
+ end if;
+
+ -- Loop to acquire unit entries
+
+ Unit_Loop : while C = 'U' loop
+ Checkc (' ');
+ Skip_Space;
+ Units.Increment_Last;
+
+ if ALIs.Table (Id).First_Unit = No_Unit_Id then
+ ALIs.Table (Id).First_Unit := Units.Last;
+ end if;
+
+ Units.Table (Units.Last).Uname := Get_Name;
+ Units.Table (Units.Last).Predefined := Is_Predefined_Unit;
+ Units.Table (Units.Last).Internal := Is_Internal_Unit;
+ Units.Table (Units.Last).My_ALI := Id;
+ Units.Table (Units.Last).Sfile := Get_Name (Lower => True);
+ Units.Table (Units.Last).Pure := False;
+ Units.Table (Units.Last).Preelab := False;
+ Units.Table (Units.Last).No_Elab := False;
+ Units.Table (Units.Last).Shared_Passive := False;
+ Units.Table (Units.Last).RCI := False;
+ Units.Table (Units.Last).Remote_Types := False;
+ Units.Table (Units.Last).Has_RACW := False;
+ Units.Table (Units.Last).Init_Scalars := False;
+ Units.Table (Units.Last).Is_Generic := False;
+ Units.Table (Units.Last).Icasing := Mixed_Case;
+ Units.Table (Units.Last).Kcasing := All_Lower_Case;
+ Units.Table (Units.Last).Dynamic_Elab := False;
+ Units.Table (Units.Last).Elaborate_Body := False;
+ Units.Table (Units.Last).Set_Elab_Entity := False;
+ Units.Table (Units.Last).Version := "00000000";
+ Units.Table (Units.Last).First_With := Withs.Last + 1;
+ Units.Table (Units.Last).First_Arg := First_Arg;
+ Units.Table (Units.Last).Elab_Position := 0;
+
+ if Debug_Flag_U then
+ Write_Str (" ----> reading unit ");
+ Write_Unit_Name (Units.Table (Units.Last).Uname);
+ Write_Str (" from file ");
+ Write_Name (Units.Table (Units.Last).Sfile);
+ Write_Eol;
+ end if;
+
+ -- Check for duplicated unit in different files
+
+ declare
+ Info : constant Int := Get_Name_Table_Info
+ (Units.Table (Units.Last).Uname);
+ begin
+ if Info /= 0
+ and then Units.Table (Units.Last).Sfile /=
+ Units.Table (Unit_Id (Info)).Sfile
+ then
+ -- If Err is set then treat duplicate unit name as an instance
+ -- of a bad ALI format. This is the case of being called from
+ -- gnatmake, and the point is that if anything is wrong with
+ -- the ALI file, then gnatmake should just recompile.
+
+ if Err then
+ raise Bad_ALI_Format;
+
+ -- If Err is not set, then this is a fatal error
+
+ else
+ Set_Standard_Error;
+ Write_Str ("error: duplicate unit name: ");
+ Write_Eol;
+
+ Write_Str ("error: unit """);
+ Write_Unit_Name (Units.Table (Units.Last).Uname);
+ Write_Str (""" found in file """);
+ Write_Name_Decoded (Units.Table (Units.Last).Sfile);
+ Write_Char ('"');
+ Write_Eol;
+
+ Write_Str ("error: unit """);
+ Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
+ Write_Str (""" found in file """);
+ Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
+ Write_Char ('"');
+ Write_Eol;
+
+ Exit_Program (E_Fatal);
+ end if;
+ end if;
+ end;
+
+ Set_Name_Table_Info
+ (Units.Table (Units.Last).Uname, Int (Units.Last));
+
+ -- Scan out possible version and other parameters
+
+ loop
+ Skip_Space;
+ exit when At_Eol;
+ C := Getc;
+
+ -- Version field
+
+ if C in '0' .. '9' or else C in 'a' .. 'f' then
+ Units.Table (Units.Last).Version (1) := C;
+
+ for J in 2 .. 8 loop
+ C := Getc;
+ Units.Table (Units.Last).Version (J) := C;
+ end loop;
+
+ -- DE parameter (Dynamic elaboration checks
+
+ elsif C = 'D' then
+ Checkc ('E');
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Dynamic_Elab := True;
+ Dynamic_Elaboration_Checks_Specified := True;
+
+ -- EB/EE parameters
+
+ elsif C = 'E' then
+ C := Getc;
+
+ if C = 'B' then
+ Units.Table (Units.Last).Elaborate_Body := True;
+
+ elsif C = 'E' then
+ Units.Table (Units.Last).Set_Elab_Entity := True;
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- GE parameter (generic)
+
+ elsif C = 'G' then
+ Checkc ('E');
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Is_Generic := True;
+
+ -- IL/IS/IU parameters
+
+ elsif C = 'I' then
+ C := Getc;
+
+ if C = 'L' then
+ Units.Table (Units.Last).Icasing := All_Lower_Case;
+
+ elsif C = 'S' then
+ Units.Table (Units.Last).Init_Scalars := True;
+ Initialize_Scalars_Used := True;
+
+ elsif C = 'U' then
+ Units.Table (Units.Last).Icasing := All_Upper_Case;
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- KM/KU parameters
+
+ elsif C = 'K' then
+ C := Getc;
+
+ if C = 'M' then
+ Units.Table (Units.Last).Kcasing := Mixed_Case;
+
+ elsif C = 'U' then
+ Units.Table (Units.Last).Kcasing := All_Upper_Case;
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- NE parameter
+
+ elsif C = 'N' then
+ Checkc ('E');
+ Units.Table (Units.Last).No_Elab := True;
+ Check_At_End_Of_Field;
+
+ -- PR/PU/PK parameters
+
+ elsif C = 'P' then
+ C := Getc;
+
+ -- PR parameter (preelaborate)
+
+ if C = 'R' then
+ Units.Table (Units.Last).Preelab := True;
+
+ -- PU parameter (pure)
+
+ elsif C = 'U' then
+ Units.Table (Units.Last).Pure := True;
+
+ -- PK indicates unit is package
+
+ elsif C = 'K' then
+ Units.Table (Units.Last).Unit_Kind := 'p';
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ -- RC/RT parameters
+
+ elsif C = 'R' then
+ C := Getc;
+
+ -- RC parameter (remote call interface)
+
+ if C = 'C' then
+ Units.Table (Units.Last).RCI := True;
+
+ -- RT parameter (remote types)
+
+ elsif C = 'T' then
+ Units.Table (Units.Last).Remote_Types := True;
+
+ -- RA parameter (remote access to class wide type)
+
+ elsif C = 'A' then
+ Units.Table (Units.Last).Has_RACW := True;
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ elsif C = 'S' then
+ C := Getc;
+
+ -- SP parameter (shared passive)
+
+ if C = 'P' then
+ Units.Table (Units.Last).Shared_Passive := True;
+
+ -- SU parameter indicates unit is subprogram
+
+ elsif C = 'U' then
+ Units.Table (Units.Last).Unit_Kind := 's';
+
+ else
+ Fatal_Error;
+ end if;
+
+ Check_At_End_Of_Field;
+
+ else
+ Fatal_Error;
+ end if;
+
+ end loop;
+
+ Skip_Eol;
+
+ -- Check if static elaboration model used
+
+ if not Units.Table (Units.Last).Dynamic_Elab
+ and then not Units.Table (Units.Last).Internal
+ then
+ Static_Elaboration_Model_Used := True;
+ end if;
+
+ -- Scan out With lines for this unit
+
+ C := Getc;
+
+ With_Loop : while C = 'W' loop
+ Checkc (' ');
+ Skip_Space;
+ Withs.Increment_Last;
+ Withs.Table (Withs.Last).Uname := Get_Name;
+ Withs.Table (Withs.Last).Elaborate := False;
+ Withs.Table (Withs.Last).Elaborate_All := False;
+ Withs.Table (Withs.Last).Elab_All_Desirable := False;
+
+ -- Generic case with no object file available
+
+ if At_Eol then
+ Withs.Table (Withs.Last).Sfile := No_File;
+ Withs.Table (Withs.Last).Afile := No_File;
+
+ -- Normal case
+
+ else
+ Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
+ Withs.Table (Withs.Last).Afile := Get_Name;
+
+ -- Scan out possible E, EA, and NE parameters
+
+ while not At_Eol loop
+ Skip_Space;
+
+ if Nextc = 'E' then
+ P := P + 1;
+
+ if At_End_Of_Field then
+ Withs.Table (Withs.Last).Elaborate := True;
+
+ elsif Nextc = 'A' then
+ P := P + 1;
+ Check_At_End_Of_Field;
+ Withs.Table (Withs.Last).Elaborate_All := True;
+
+ else
+ Checkc ('D');
+ Check_At_End_Of_Field;
+
+ -- Store ED indication unless ignore required
+
+ if not Ignore_ED then
+ Withs.Table (Withs.Last).Elab_All_Desirable := True;
+ end if;
+ end if;
+ end if;
+ end loop;
+ end if;
+
+ Skip_Eol;
+ C := Getc;
+
+ end loop With_Loop;
+
+ Units.Table (Units.Last).Last_With := Withs.Last;
+ Units.Table (Units.Last).Last_Arg := Args.Last;
+
+ end loop Unit_Loop;
+
+ -- End loop through units for one ALI file
+
+ ALIs.Table (Id).Last_Unit := Units.Last;
+ ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
+
+ -- Set types of the units (there can be at most 2 of them)
+
+ if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
+ Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
+ Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
+
+ else
+ -- Deal with body only and spec only cases, note that the reason we
+ -- do our own checking of the name (rather than using Is_Body_Name)
+ -- is that Uname drags in far too much compiler junk!
+
+ Get_Name_String (Units.Table (Units.Last).Uname);
+
+ if Name_Buffer (Name_Len) = 'b' then
+ Units.Table (Units.Last).Utype := Is_Body_Only;
+ else
+ Units.Table (Units.Last).Utype := Is_Spec_Only;
+ end if;
+ end if;
+
+ -- If there are linker options lines present, scan them
+
+ while C = 'L' loop
+ Checkc (' ');
+ Skip_Space;
+ Checkc ('"');
+
+ Name_Len := 0;
+ loop
+ C := Getc;
+
+ if C < Character'Val (16#20#)
+ or else C > Character'Val (16#7E#)
+ then
+ Fatal_Error;
+
+ elsif C = '{' then
+ C := Character'Val (0);
+
+ declare
+ V : Natural;
+
+ begin
+ V := 0;
+ for J in 1 .. 2 loop
+ C := Getc;
+
+ if C in '0' .. '9' then
+ V := V * 16 +
+ Character'Pos (C) - Character'Pos ('0');
+
+ elsif C in 'A' .. 'F' then
+ V := V * 16 +
+ Character'Pos (C) - Character'Pos ('A') + 10;
+
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ Checkc ('}');
+
+ Add_Char_To_Name_Buffer (Character'Val (V));
+ end;
+
+ else
+ if C = '"' then
+ exit when Nextc /= '"';
+ C := Getc;
+ end if;
+
+ Add_Char_To_Name_Buffer (C);
+ end if;
+ end loop;
+
+ Add_Char_To_Name_Buffer (nul);
+
+ Skip_Eol;
+ C := Getc;
+
+ Linker_Options.Increment_Last;
+
+ Linker_Options.Table (Linker_Options.Last).Name
+ := Name_Enter;
+
+ Linker_Options.Table (Linker_Options.Last).Unit
+ := ALIs.Table (Id).First_Unit;
+
+ Linker_Options.Table (Linker_Options.Last).Internal_File
+ := Is_Internal_File_Name (F);
+
+ Linker_Options.Table (Linker_Options.Last).Original_Pos
+ := Linker_Options.Last;
+
+ end loop;
+
+ -- Scan out external version references and put in hash table
+
+ while C = 'E' loop
+ Checkc (' ');
+ Skip_Space;
+
+ Name_Len := 0;
+ Name_Len := 0;
+ loop
+ C := Getc;
+
+ if C < ' ' then
+ Fatal_Error;
+ end if;
+
+ exit when At_End_Of_Field;
+ Add_Char_To_Name_Buffer (C);
+ end loop;
+
+ Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
+ Skip_Eol;
+ C := Getc;
+ end loop;
+
+ -- Scan out source dependency lines for this ALI file
+
+ ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
+
+ while C = 'D' loop
+ Checkc (' ');
+ Skip_Space;
+ Sdep.Increment_Last;
+ Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
+ Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
+
+ -- Check for version number present, and if so store it
+
+ Skip_Space;
+
+ declare
+ Ctr : Natural;
+ Chk : Word;
+
+ begin
+ Ctr := 0;
+ Chk := 0;
+
+ loop
+ exit when At_Eol or else Ctr = 8;
+
+ if Nextc in '0' .. '9' then
+ Chk := Chk * 16 +
+ Character'Pos (Nextc) - Character'Pos ('0');
+
+ elsif Nextc in 'A' .. 'F' then
+ Chk := Chk * 16 +
+ Character'Pos (Nextc) - Character'Pos ('A') + 10;
+
+ else
+ exit;
+ end if;
+
+ Ctr := Ctr + 1;
+ P := P + 1;
+ end loop;
+
+ if Ctr = 8 and then At_End_Of_Field then
+ Sdep.Table (Sdep.Last).Checksum := Chk;
+ else
+ Fatal_Error;
+ end if;
+ end;
+
+ -- Acquire subunit and reference file name entries
+
+ Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
+ Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile;
+ Sdep.Table (Sdep.Last).Start_Line := 1;
+
+ if not At_Eol then
+ Skip_Space;
+
+ -- Here for subunit name
+
+ if Nextc not in '0' .. '9' then
+ Name_Len := 0;
+
+ while not At_End_Of_Field loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
+
+ Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
+ Skip_Space;
+ end if;
+
+ -- Here for reference file name entry
+
+ if Nextc in '0' .. '9' then
+ Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
+ Checkc (':');
+
+ Name_Len := 0;
+
+ while not At_End_Of_Field loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
+
+ Sdep.Table (Sdep.Last).Rfile := Name_Enter;
+ end if;
+ end if;
+
+ Skip_Eol;
+ C := Getc;
+ end loop;
+
+ ALIs.Table (Id).Last_Sdep := Sdep.Last;
+
+ -- Loop through Xref sections (skip loop if not reading xref stuff)
+
+ while Read_Xref and then C = 'X' loop
+
+ -- Make new entry in section table
+
+ Xref_Section.Increment_Last;
+
+ declare
+ XS : Xref_Section_Record renames
+ Xref_Section.Table (Xref_Section.Last);
+
+ Current_File_Num : Sdep_Id;
+ -- Keeps track of the current file number (changed by nn|)
+
+ begin
+ XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
+ XS.File_Name := Get_Name;
+ XS.First_Entity := Xref_Entity.Last + 1;
+
+ Current_File_Num := XS.File_Num;
+
+ Skip_Eol;
+ C := Nextc;
+
+ -- Loop through Xref entities
+
+ while C /= 'X' and then C /= EOF loop
+ Xref_Entity.Increment_Last;
+
+ declare
+ XE : Xref_Entity_Record renames
+ Xref_Entity.Table (Xref_Entity.Last);
+
+ N : Nat;
+
+ begin
+ XE.Line := Get_Nat;
+ XE.Etype := Getc;
+ XE.Col := Get_Nat;
+ XE.Lib := (Getc = '*');
+ XE.Entity := Get_Name;
+
+ Skip_Space;
+
+ if Nextc = '<' then
+ P := P + 1;
+ N := Get_Nat;
+
+ if Nextc = '|' then
+ XE.Ptype_File_Num :=
+ Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
+ Current_File_Num := XE.Ptype_File_Num;
+ P := P + 1;
+ N := Get_Nat;
+
+ else
+ XE.Ptype_File_Num := Current_File_Num;
+ end if;
+
+ XE.Ptype_Line := N;
+ XE.Ptype_Type := Getc;
+ XE.Ptype_Col := Get_Nat;
+
+ else
+ XE.Ptype_File_Num := No_Sdep_Id;
+ XE.Ptype_Line := 0;
+ XE.Ptype_Type := ' ';
+ XE.Ptype_Col := 0;
+ end if;
+
+ XE.First_Xref := Xref.Last + 1;
+
+ -- Loop through cross-references for this entity
+
+ Current_File_Num := XS.File_Num;
+
+ loop
+ Skip_Space;
+
+ if At_Eol then
+ Skip_Eol;
+ exit when Nextc /= '.';
+ P := P + 1;
+ end if;
+
+ Xref.Increment_Last;
+
+ declare
+ XR : Xref_Record renames Xref.Table (Xref.Last);
+
+ begin
+ N := Get_Nat;
+
+ if Nextc = '|' then
+ XR.File_Num :=
+ Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
+ Current_File_Num := XR.File_Num;
+ P := P + 1;
+ N := Get_Nat;
+
+ else
+ XR.File_Num := Current_File_Num;
+ end if;
+
+ XR.Line := N;
+ XR.Rtype := Getc;
+ XR.Col := Get_Nat;
+ end;
+ end loop;
+
+ -- Record last cross-reference
+
+ XE.Last_Xref := Xref.Last;
+ C := Nextc;
+ end;
+ end loop;
+
+ -- Record last entity
+
+ XS.Last_Entity := Xref_Entity.Last;
+ end;
+
+ C := Getc;
+ end loop;
+
+ -- Here after dealing with xref sections
+
+ if C /= EOF and then C /= 'X' then
+ Fatal_Error;
+ end if;
+
+ return Id;
+
+ exception
+ when Bad_ALI_Format =>
+ return No_ALI_Id;
+
+ end Scan_ALI;
+
+ ---------
+ -- SEq --
+ ---------
+
+ function SEq (F1, F2 : String_Ptr) return Boolean is
+ begin
+ return F1.all = F2.all;
+ end SEq;
+
+ -----------
+ -- SHash --
+ -----------
+
+ function SHash (S : String_Ptr) return Vindex is
+ H : Word;
+
+ begin
+ H := 0;
+ for J in S.all'Range loop
+ H := H * 2 + Character'Pos (S (J));
+ end loop;
+
+ return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
+ end SHash;
+
+end ALI;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.71 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package defines the internal data structures used for representation
+-- of Ada Library Information (ALI) acquired from the ALI files generated
+-- by the front end.
+
+with Casing; use Casing;
+with Gnatvsn; use Gnatvsn;
+with Rident; use Rident;
+with Table;
+with Types; use Types;
+
+with GNAT.HTable; use GNAT.HTable;
+
+package ALI is
+
+ --------------
+ -- Id Types --
+ --------------
+
+ -- The various entries are stored in tables with distinct subscript
+ -- ranges. The following type definitions indicate the ranges used
+ -- for the subscripts (Id values) for the various tables.
+
+ type ALI_Id is range 0 .. 999_999;
+ -- Id values used for ALIs table entries
+
+ type Unit_Id is range 1_000_000 .. 1_999_999;
+ -- Id values used for Unit table entries
+
+ type With_Id is range 2_000_000 .. 2_999_999;
+ -- Id values used for Withs table entries
+
+ type Arg_Id is range 3_000_000 .. 3_999_999;
+ -- Id values used for argument table entries
+
+ type Sdep_Id is range 4_000_000 .. 4_999_999;
+ -- Id values used for Sdep table entries
+
+ type Source_Id is range 5_000_000 .. 5_999_999;
+ -- Id values used for Source table entries
+
+ --------------------
+ -- ALI File Table --
+ --------------------
+
+ -- Each ALI file read generates an entry in the ALIs table
+
+ No_ALI_Id : constant ALI_Id := ALI_Id'First;
+ -- Special value indicating no ALI entry
+
+ First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1;
+ -- Id of first actual entry in table
+
+ type Main_Program_Type is (None, Proc, Func);
+ -- Indicator of whether unit can be used as main program
+
+ type Restrictions_String is array (Partition_Restrictions) of Character;
+ -- Type used to hold string from R line
+
+ type ALIs_Record is record
+
+ Afile : File_Name_Type;
+ -- Name of ALI file
+
+ Ofile_Full_Name : Name_Id;
+ -- Full name of object file corresponding to the ALI file
+
+ Sfile : File_Name_Type;
+ -- Name of source file that generates this ALI file (which is equal
+ -- to the name of the source file in the first unit table entry for
+ -- this ALI file, since the body if present is always first).
+
+ Ver : String (1 .. Ver_Len_Max);
+ -- Value of library version (V line in ALI file)
+
+ Ver_Len : Natural;
+ -- Length of characters stored in Ver
+
+ First_Unit : Unit_Id;
+ -- Id of first Unit table entry for this file
+
+ Last_Unit : Unit_Id;
+ -- Id of last Unit table entry for this file
+
+ First_Sdep : Sdep_Id;
+ -- Id of first Sdep table entry for this file
+
+ Last_Sdep : Sdep_Id;
+ -- Id of last Sdep table entry for this file
+
+ Main_Program : Main_Program_Type;
+ -- Indicator of whether first unit can be used as main program
+
+ Main_Priority : Int;
+ -- Indicates priority value if Main_Program field indicates that
+ -- this can be a main program. A value of -1 (No_Main_Priority)
+ -- indicates that no parameter was found, or no M line was present.
+
+ Time_Slice_Value : Int;
+ -- Indicates value of time slice parameter from T=xxx on main program
+ -- line. A value of -1 indicates that no T=xxx parameter was found,
+ -- or no M line was present.
+
+ WC_Encoding : Character;
+ -- Wide character encoding if main procedure. Otherwise not relevant.
+
+ Locking_Policy : Character;
+ -- Indicates locking policy for units in this file. Space means
+ -- tasking was not used, or that no Locking_Policy pragma was
+ -- present or that this is a language defined unit. Otherwise set
+ -- to first character (upper case) of policy name.
+
+ Queuing_Policy : Character;
+ -- Indicates queuing policy for units in this file. Space means
+ -- tasking was not used, or that no Queuing_Policy pragma was
+ -- present or that this is a language defined unit. Otherwise set
+ -- to first character (upper case) of policy name.
+
+ Task_Dispatching_Policy : Character;
+ -- Indicates task dispatching policy for units in this file. Space
+ -- means tasking was not used, or that no Task_Dispatching_Policy
+ -- pragma was present or that this is a language defined unit.
+ -- Otherwise set to first character (upper case) of policy name.
+
+ Compile_Errors : Boolean;
+ -- Set to True if compile errors for unit. Note that No_Object
+ -- will always be set as well in this case.
+
+ Float_Format : Character;
+ -- Set to float format (set to I if no float-format given)
+
+ No_Object : Boolean;
+ -- Set to True if no object file generated
+
+ No_Run_Time : Boolean;
+ -- Set to True if file was compiled with pragma No_Run_Time
+
+ Normalize_Scalars : Boolean;
+ -- Set to True if file was compiled with Normalize_Scalars
+
+ Unit_Exception_Table : Boolean;
+ -- Set to True if unit exception table pointer generated
+
+ Zero_Cost_Exceptions : Boolean;
+ -- Set to True if file was compiled with zero cost exceptions
+
+ Restrictions : Restrictions_String;
+ -- Copy of restrictions letters from R line
+
+ end record;
+
+ No_Main_Priority : constant Int := -1;
+ -- Code for no main priority set
+
+ package ALIs is new Table.Table (
+ Table_Component_Type => ALIs_Record,
+ Table_Index_Type => ALI_Id,
+ Table_Low_Bound => First_ALI_Entry,
+ Table_Initial => 500,
+ Table_Increment => 200,
+ Table_Name => "ALIs");
+
+ ----------------
+ -- Unit Table --
+ ----------------
+
+ -- Each unit within an ALI file generates an entry in the unit table
+
+ No_Unit_Id : constant Unit_Id := Unit_Id'First;
+ -- Special value indicating no unit table entry
+
+ First_Unit_Entry : constant Unit_Id := No_Unit_Id + 1;
+ -- Id of first actual entry in table
+
+ type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only);
+ -- Indicates type of entry, if both body and spec appear in the ALI file,
+ -- then the first unit is marked Is_Body, and the second is marked Is_Spec.
+ -- If only a spec appears, then it is marked as Is_Spec_Only, and if only
+ -- a body appears, then it is marked Is_Body_Only).
+
+ subtype Version_String is String (1 .. 8);
+ -- Version string, taken from unit record
+
+ type Unit_Record is record
+
+ My_ALI : ALI_Id;
+ -- Corresponding ALI entry
+
+ Uname : Unit_Name_Type;
+ -- Name of Unit
+
+ Sfile : File_Name_Type;
+ -- Name of source file
+
+ Preelab : Boolean;
+ -- Indicates presence of PR parameter for a preelaborated package
+
+ No_Elab : Boolean;
+ -- Indicates presence of NE parameter for a unit that has does not
+ -- have an elaboration routine (since it has no elaboration code).
+
+ Pure : Boolean;
+ -- Indicates presence of PU parameter for a pure package
+
+ Dynamic_Elab : Boolean;
+ -- Set to True if the unit was compiled with dynamic elaboration
+ -- checks (i.e. either -gnatE or pragma Elaboration_Checks (Static)
+ -- was used to compile the unit).
+
+ Elaborate_Body : Boolean;
+ -- Indicates presence of EB parameter for a package which has a
+ -- pragma Preelaborate_Body.
+
+ Set_Elab_Entity : Boolean;
+ -- Indicates presence of EE parameter for a unit which has an
+ -- elaboration entity which must be set true as part of the
+ -- elaboration of the entity.
+
+ Has_RACW : Boolean;
+ -- Indicates presence of RA parameter for a package that declares
+ -- at least one Remote Access to Class_Wide (RACW) object.
+
+ Remote_Types : Boolean;
+ -- Indicates presence of RT parameter for a package which has a
+ -- pragma Remote_Types.
+
+ Shared_Passive : Boolean;
+ -- Indicates presence of SP parameter for a package which has a
+ -- pragma Shared_Passive.
+
+ RCI : Boolean;
+ -- Indicates presence of RC parameter for a package which has a
+ -- pragma Remote_Call_Interface.
+
+ Predefined : Boolean;
+ -- Indicates if unit is language predefined (or a child of such a unit)
+
+ Internal : Boolean;
+ -- Indicates if unit is an internal unit (or a child of such a unit)
+
+ First_With : With_Id;
+ -- Id of first withs table entry for this file
+
+ Last_With : With_Id;
+ -- Id of last withs table entry for this file
+
+ First_Arg : Arg_Id;
+ -- Id of first args table entry for this file
+
+ Last_Arg : Arg_Id;
+ -- Id of last args table entry for this file
+
+ Utype : Unit_Type;
+ -- Type of entry
+
+ Is_Generic : Boolean;
+ -- True for generic unit (i.e. a generic declaration, or a generic
+ -- body). False for a non-generic unit.
+
+ Unit_Kind : Character;
+ -- Indicates the nature of the unit. 'p' for Packages and 's' for
+ -- subprograms.
+
+ Version : Version_String;
+ -- Version of unit
+
+ Icasing : Casing_Type;
+ -- Indicates casing of identifiers in source file for this unit. This
+ -- is used for informational output, and also for constructing the
+ -- main unit if it is being built in Ada.
+
+ Kcasing : Casing_Type;
+ -- Indicates casing of keyowords in source file for this unit. This
+ -- is used for informational output, and also for constructing the
+ -- main unit if it is being built in Ada.
+
+ Elab_Position : aliased Natural;
+ -- Initialized to zero. Set non-zero when a unit is chosen and
+ -- placed in the elaboration order. The value represents the
+ -- ordinal position in the elaboration order.
+
+ Init_Scalars : Boolean;
+ -- Set True if IS qualifier appears in ALI file, indicating that
+ -- an Initialize_Scalars pragma applies to the unit.
+
+ end record;
+
+ package Units is new Table.Table (
+ Table_Component_Type => Unit_Record,
+ Table_Index_Type => Unit_Id,
+ Table_Low_Bound => First_Unit_Entry,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "Unit");
+
+ --------------
+ -- Switches --
+ --------------
+
+ -- These switches record status information about ali files that
+ -- have been read, for quick reference without searching tables.
+
+ Dynamic_Elaboration_Checks_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if Read_ALI reads
+ -- a unit for which dynamic elaboration checking is enabled.
+
+ Float_Format_Specified : Character := ' ';
+ -- Set to blank by Initialize_ALI. Set to appropriate float format
+ -- character (V or I, see Opt.Float_Format) if an an ali file that
+ -- is read contains an F line setting the floating point format.
+
+ Initialize_Scalars_Used : Boolean := False;
+ -- Set True if an ali file contains the Initialize_Scalars flag
+
+ Locking_Policy_Specified : Character := ' ';
+ -- Set to blank by Initialize_ALI. Set to the appropriate locking policy
+ -- character if an ali file contains a P line setting the locking policy.
+
+ No_Normalize_Scalars_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file indicates
+ -- that the file was compiled without normalize scalars.
+
+ No_Object_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file contains
+ -- the No_Object flag.
+
+ Normalize_Scalars_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file indicates
+ -- that the file was compiled in Normalize_Scalars mode.
+
+ No_Run_Time_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI, Set to True if an ali file indicates
+ -- that the file was compiled in No_Run_Time mode.
+
+ Queuing_Policy_Specified : Character := ' ';
+ -- Set to blank by Initialize_ALI. Set to the appropriate queuing policy
+ -- character if an ali file contains a P line setting the queuing policy.
+
+ Static_Elaboration_Model_Used : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if any ALI file for a
+ -- non-internal unit compiled with the static elaboration model is
+ -- encountered.
+
+ Task_Dispatching_Policy_Specified : Character := ' ';
+ -- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
+ -- policy character if an ali file contains a P line setting the
+ -- task dispatching policy.
+
+ Unreserve_All_Interrupts_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file is read that
+ -- has P line specifying unreserve all interrupts mode.
+
+ Zero_Cost_Exceptions_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file is read that
+ -- has a P line specifying the generation of zero cost exceptions.
+
+ -----------------
+ -- Withs Table --
+ -----------------
+
+ -- Each With line (W line) in an ALI file generates a Withs table entry
+
+ No_With_Id : constant With_Id := With_Id'First;
+ -- Special value indicating no withs table entry
+
+ First_With_Entry : constant With_Id := No_With_Id + 1;
+ -- Id of first actual entry in table
+
+ type With_Record is record
+
+ Uname : Unit_Name_Type;
+ -- Name of Unit
+
+ Sfile : File_Name_Type;
+ -- Name of source file, set to No_File in generic case
+
+ Afile : File_Name_Type;
+ -- Name of ALI file, set to No_File in generic case
+
+ Elaborate : Boolean;
+ -- Indicates presence of E parameter
+
+ Elaborate_All : Boolean;
+ -- Indicates presence of EA parameter
+
+ Elab_All_Desirable : Boolean;
+ -- Indicates presence of ED parameter
+
+ end record;
+
+ package Withs is new Table.Table (
+ Table_Component_Type => With_Record,
+ Table_Index_Type => With_Id,
+ Table_Low_Bound => First_With_Entry,
+ Table_Initial => 5000,
+ Table_Increment => 200,
+ Table_Name => "Withs");
+
+ ---------------------
+ -- Arguments Table --
+ ---------------------
+
+ -- Each Arg line (A line) in an ALI file generates an Args table entry
+
+ No_Arg_Id : constant Arg_Id := Arg_Id'First;
+ -- Special value indicating no args table entry
+
+ First_Arg_Entry : constant Arg_Id := No_Arg_Id + 1;
+ -- Id of first actual entry in table
+
+ package Args is new Table.Table (
+ Table_Component_Type => String_Ptr,
+ Table_Index_Type => Arg_Id,
+ Table_Low_Bound => First_Arg_Entry,
+ Table_Initial => 1000,
+ Table_Increment => 100,
+ Table_Name => "Args");
+
+ --------------------------
+ -- Linker_Options Table --
+ --------------------------
+
+ -- Each unique linker option (L line) in an ALI file generates
+ -- an entry in the Linker_Options table. Note that only unique
+ -- entries are stored, i.e. if the same entry appears twice, the
+ -- second entry is suppressed. Each entry is a character sequence
+ -- terminated by a NUL character.
+
+ type Linker_Option_Record is record
+ Name : Name_Id;
+ Unit : Unit_Id;
+ Internal_File : Boolean;
+ Original_Pos : Positive;
+ end record;
+
+ -- Declare the Linker_Options Table
+
+ -- The indexes of active entries in this table range from 1 to the
+ -- value of Linker_Options.Last. The zero'th element is for sort call.
+
+ package Linker_Options is new Table.Table (
+ Table_Component_Type => Linker_Option_Record,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 200,
+ Table_Increment => 400,
+ Table_Name => "Linker_Options");
+
+ -------------------------------------------
+ -- External Version Reference Hash Table --
+ -------------------------------------------
+
+ -- This hash table keeps track of external version reference strings
+ -- as read from E lines in the ali file. The stored values do not
+ -- include the terminating quote characters.
+
+ type Vindex is range 0 .. 98;
+ -- Type to define range of headers
+
+ function SHash (S : String_Ptr) return Vindex;
+ -- Hash function for this table
+
+ function SEq (F1, F2 : String_Ptr) return Boolean;
+ -- Equality function for this table
+
+ package Version_Ref is new Simple_HTable (
+ Header_Num => Vindex,
+ Element => Boolean,
+ No_Element => False,
+ Key => String_Ptr,
+ Hash => SHash,
+ Equal => SEq);
+
+ ------------------------------------
+ -- Sdep (Source Dependency) Table --
+ ------------------------------------
+
+ -- Each source dependency (D line) in an ALI file generates an
+ -- entry in the Sdep table.
+
+ No_Sdep_Id : constant Sdep_Id := Sdep_Id'First;
+ -- Special value indicating no Sdep table entry
+
+ First_Sdep_Entry : constant Sdep_Id := No_Sdep_Id + 1;
+ -- Id of first actual entry in table
+
+ type Sdep_Record is record
+
+ Sfile : File_Name_Type;
+ -- Name of source file
+
+ Stamp : Time_Stamp_Type;
+ -- Time stamp value
+
+ Checksum : Word;
+ -- Checksum value
+
+ Subunit_Name : Name_Id;
+ -- Name_Id for subunit name if present, else No_Name
+
+ Rfile : File_Name_Type;
+ -- Reference file name. Same as Sfile unless a Source_Reference
+ -- pragma was used, in which case it reflects the name used in
+ -- the pragma.
+
+ Start_Line : Nat;
+ -- Starting line number in file. Always 1, unless a Source_Reference
+ -- pragma was used, in which case it reflects the line number value
+ -- given in the pragma.
+
+ end record;
+
+ package Sdep is new Table.Table (
+ Table_Component_Type => Sdep_Record,
+ Table_Index_Type => Sdep_Id,
+ Table_Low_Bound => First_Sdep_Entry,
+ Table_Initial => 5000,
+ Table_Increment => 200,
+ Table_Name => "Sdep");
+
+ ----------------------------
+ -- Use of Name Table Info --
+ ----------------------------
+
+ -- All unit names and file names are entered into the Names table. The
+ -- Info fields of these entries are used as follows:
+
+ -- Unit name Info field has Unit_Id of unit table entry
+ -- ALI file name Info field has ALI_Id of ALI table entry
+ -- Source file name Info field has Source_Id of source table entry
+
+ --------------------------
+ -- Cross-Reference Data --
+ --------------------------
+
+ -- The following table records cross-reference sections, there is one
+ -- entry for each X header line in the ALI file for an xref section.
+ -- Note that there will be no entries in this table if the Read_Xref
+ -- parameter to Scan_ALI was set to False.
+
+ type Xref_Section_Record is record
+ File_Num : Sdep_Id;
+ -- Dependency number for file (entry in Sdep.Table)
+
+ File_Name : Name_Id;
+ -- Name of file
+
+ First_Entity : Nat;
+ -- First entry in Xref_Entity table
+
+ Last_Entity : Nat;
+ -- Last entry in Xref_Entity table
+
+ end record;
+
+ package Xref_Section is new Table.Table (
+ Table_Component_Type => Xref_Section_Record,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 300,
+ Table_Name => "Xref_Section");
+
+ -- The following table records entities for which xrefs are recorded
+
+ type Xref_Entity_Record is record
+ Line : Pos;
+ -- Line number of definition
+
+ Etype : Character;
+ -- Set to the identification character for the entity. See section
+ -- "Cross-Reference Entity Indentifiers in lib-xref.ads for details.
+
+ Col : Pos;
+ -- Column number of definition
+
+ Lib : Boolean;
+ -- True if entity is library level entity
+
+ Entity : Name_Id;
+ -- Name of entity
+
+ Ptype_File_Num : Sdep_Id;
+ -- This field is set to No_Sdep_Id if no ptype (parent type) entry
+ -- is present, otherwise it is the file dependency reference for
+ -- the parent type declaration.
+
+ Ptype_Line : Nat;
+ -- Set to zero if no ptype (parent type) entry, otherwise this is
+ -- the line number of the declaration of the parent type.
+
+ Ptype_Type : Character;
+ -- Set to blank if no ptype (parent type) entry, otherwise this is
+ -- the identification character for the parent type. See section
+ -- "Cross-Reference Entity Indentifiers in lib-xref.ads for details.
+
+ Ptype_Col : Nat;
+ -- Set to zero if no ptype (parent type) entry, otherwise this is
+ -- the column number of the declaration of the parent type.
+
+ First_Xref : Nat;
+ -- Index into Xref table of first cross-reference
+
+ Last_Xref : Nat;
+ -- Index into Xref table of last cross-reference. The value in
+ -- Last_Xref can be less than the First_Xref value to indicate
+ -- that no entries are present in the Xref Table.
+ end record;
+
+ package Xref_Entity is new Table.Table (
+ Table_Component_Type => Xref_Entity_Record,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 500,
+ Table_Increment => 300,
+ Table_Name => "Xref_Entity");
+
+ -- The following table records actual cross-references
+
+ type Xref_Record is record
+ File_Num : Sdep_Id;
+ -- Set to the file dependency number for the cross-reference. Note
+ -- that if no file entry is present explicitly, this is just a copy
+ -- of the reference for the current cross-reference section.
+
+ Line : Pos;
+ -- Line number for the reference
+
+ Rtype : Character;
+ -- Indicates type of reference, using code used in ALI file:
+ -- r = reference
+ -- m = modification
+ -- b = body entity
+ -- c = completion of private or incomplete type
+ -- x = type extension
+ -- i = implicit reference
+ -- See description in lib-xref.ads for further details
+
+ Col : Pos;
+ -- Column number for the reference
+ end record;
+
+ package Xref is new Table.Table (
+ Table_Component_Type => Xref_Record,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 2000,
+ Table_Increment => 300,
+ Table_Name => "Xref");
+
+ --------------------------------------
+ -- Subprograms for Reading ALI File --
+ --------------------------------------
+
+ procedure Initialize_ALI;
+ -- Initialize the ALI tables. Also resets all switch values to defaults.
+
+ function Scan_ALI
+ (F : File_Name_Type;
+ T : Text_Buffer_Ptr;
+ Ignore_ED : Boolean;
+ Err : Boolean;
+ Read_Xref : Boolean := False)
+ return ALI_Id;
+ -- Given the text, T, of an ALI file, F, scan and store the information
+ -- from the file, and return the Id of the resulting entry in the ALI
+ -- table. Switch settings may be modified as described above in the
+ -- switch description settings.
+ --
+ -- Ignore_ED is normally False. If set to True, it indicates that
+ -- all ED (elaboration desirable) indications in the ALI file are
+ -- to be ignored.
+ --
+ -- Err determines the action taken on an incorrectly formatted file.
+ -- If Err is False, then an error message is output, and the program
+ -- is terminated. If Err is True, then no error message is output,
+ -- and No_ALI_Id is returned.
+ --
+ -- Read_XREF is set True to read and acquire the cross-reference
+ -- information, otherwise the scan is terminated when a cross-
+ -- reference line is encountered.
+
+end ALI;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A L L O C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.23 $
+-- --
+-- 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 package contains definitions for initial sizes and growth increments
+-- for the various dynamic arrays used for principle compiler data strcutures.
+-- The indicated initial size is allocated for the start of each file, and
+-- the increment factor is a percentage used to increase the table size when
+-- it needs expanding (e.g. a value of 100 = 100% increase = double)
+
+-- Note: the initial values here are multiplied by Table_Factor, as set
+-- by the -gnatTnn switch. This variable is defined in Opt, as is the
+-- default value for the table factor.
+
+package Alloc is
+
+ -- The comment shows the unit in which the table is defined
+
+ All_Interp_Initial : constant := 1_000; -- Sem_Type
+ All_Interp_Increment : constant := 100;
+
+ Branches_Initial : constant := 1_000; -- Sem_Warn
+ Branches_Increment : constant := 100;
+
+ Conditionals_Initial : constant := 1_000; -- Sem_Warn
+ Conditionals_Increment : constant := 100;
+
+ Conditional_Stack_Initial : constant := 50; -- Sem_Warn
+ Conditional_Stack_Increment : constant := 100;
+
+ Elists_Initial : constant := 200; -- Elists
+ Elists_Increment : constant := 100;
+
+ Elmts_Initial : constant := 1_200; -- Elists
+ Elmts_Increment : constant := 100;
+
+ Entity_Suppress_Initial : constant := 100; -- Sem
+ Entity_Suppress_Increment : constant := 200;
+
+ Inlined_Bodies_Initial : constant := 50; -- Inline
+ Inlined_Bodies_Increment : constant := 200;
+
+ Inlined_Initial : constant := 100; -- Inline
+ Inlined_Increment : constant := 100;
+
+ Interp_Map_Initial : constant := 200; -- Sem_Type
+ Interp_Map_Increment : constant := 100;
+
+ Lines_Initial : constant := 500; -- Sinput
+ Lines_Increment : constant := 150;
+
+ Linker_Option_Lines_Initial : constant := 5; -- Lib
+ Linker_Option_Lines_Increment : constant := 200;
+
+ Lists_Initial : constant := 4_000; -- Nlists
+ Lists_Increment : constant := 200;
+
+ Load_Stack_Initial : constant := 10; -- Lib
+ Load_Stack_Increment : constant := 100;
+
+ Name_Chars_Initial : constant := 50_000; -- Namet
+ Name_Chars_Increment : constant := 100;
+
+ Name_Qualify_Units_Initial : constant := 200; -- Exp_Dbug
+ Name_Qualify_Units_Increment : constant := 300;
+
+ Names_Initial : constant := 6_000; -- Namet
+ Names_Increment : constant := 100;
+
+ Nodes_Initial : constant := 50_000; -- Atree
+ Nodes_Increment : constant := 100;
+
+ Orig_Nodes_Initial : constant := 50_000; -- Atree
+ Orig_Nodes_Increment : constant := 100;
+
+ Pending_Instantiations_Initial : constant := 10; -- Inline
+ Pending_Instantiations_Increment : constant := 100;
+
+ Rep_Table_Initial : constant := 1000; -- Repinfo
+ Rep_Table_Increment : constant := 200;
+
+ Scope_Stack_Initial : constant := 10; -- Sem
+ Scope_Stack_Increment : constant := 200;
+
+ SFN_Table_Initial : constant := 10; -- Fname
+ SFN_Table_Increment : constant := 200;
+
+ Source_File_Initial : constant := 10; -- Sinput
+ Source_File_Increment : constant := 200;
+
+ String_Chars_Initial : constant := 2_500; -- Stringt
+ String_Chars_Increment : constant := 150;
+
+ Strings_Initial : constant := 5_00; -- Stringt
+ Strings_Increment : constant := 150;
+
+ Successors_Initial : constant := 2_00; -- Inline
+ Successors_Increment : constant := 100;
+
+ Udigits_Initial : constant := 10_000; -- Uintp
+ Udigits_Increment : constant := 100;
+
+ Uints_Initial : constant := 5_000; -- Uintp
+ Uints_Increment : constant := 100;
+
+ Units_Initial : constant := 30; -- Lib
+ Units_Increment : constant := 100;
+
+ Ureals_Initial : constant := 200; -- Urealp
+ Ureals_Increment : constant := 100;
+
+ Unreferenced_Entities_Initial : constant := 1_000; -- Sem_Warn
+ Unreferenced_Entities_Increment : constant := 100;
+
+ With_List_Initial : constant := 10; -- Features
+ With_List_Increment : constant := 300;
+
+ Xrefs_Initial : constant := 5_000; -- Cross-refs
+ Xrefs_Increment : constant := 300;
+
+end Alloc;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A R G V *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+/* Routines for accessing command line arguments from both the runtime
+ library and from the compiler itself. In the former case, gnat_argc
+ and gnat_argv are the original argc and argv values as stored by the
+ binder generated main program, and these routines are accessed from
+ the Ada.Command_Line package. In the compiler case, gnat_argc and
+ gnat_argv are the values as modified by toplev, and these routines
+ are accessed from the Osint package. */
+
+/* Also routines for accessing the environment from the runtime library.
+ Gnat_envp is the original envp value as stored by the binder generated
+ main program, and these routines are accessed from the
+ Ada.Command_Line.Environment package. */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+
+/* argc and argv of the main program are saved under gnat_argc and gnat_argv,
+ envp of the main program is saved under gnat_envp. */
+
+int gnat_argc = 0;
+const char **gnat_argv = (const char **) 0;
+const char **gnat_envp = (const char **) 0;
+
+int
+__gnat_arg_count ()
+{
+ return gnat_argc;
+}
+
+int
+__gnat_len_arg (arg_num)
+ int arg_num;
+{
+ return strlen (gnat_argv[arg_num]);
+}
+
+void
+__gnat_fill_arg (a, i)
+ char *a;
+ int i;
+{
+ strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
+}
+
+int
+__gnat_env_count ()
+{
+ int i;
+
+ for (i = 0; gnat_envp[i]; i++)
+ ;
+ return i;
+}
+
+int
+__gnat_len_env (env_num)
+ int env_num;
+{
+ return strlen (gnat_envp[env_num]);
+}
+
+void
+__gnat_fill_env (a, i)
+ char *a;
+ int i;
+{
+ strncpy (a, gnat_envp[i], strlen (gnat_envp[i]));
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A T R E E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.205 $
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+-- Turn off subprogram ordering check for this package
+
+-- WARNING: There is a C version of this package. Any changes to this source
+-- file must be properly reflected in the C header a-atree.h (for inlined
+-- bodies) and the C file a-atree.c (for remaining non-inlined bodies).
+
+with Debug; use Debug;
+with Nlists; use Nlists;
+with Elists; use Elists;
+with Output; use Output;
+with Sinput; use Sinput;
+with Tree_IO; use Tree_IO;
+
+with GNAT.HTable; use GNAT.HTable;
+
+package body Atree is
+
+ Node_Count : Nat;
+ -- Count allocated nodes for Num_Nodes function
+
+ use Unchecked_Access;
+ -- We are allowed to see these from within our own body!
+
+ use Atree_Private_Part;
+ -- We are also allowed to see our private data structures!
+
+ function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind);
+ function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind);
+ -- Functions used to store Entity_Kind value in Nkind field
+
+ -- The following declarations are used to store flags 65-72 in the
+ -- Nkind field of the third component of an extended (entity) node.
+
+ type Flag_Byte is record
+ Flag65 : Boolean;
+ Flag66 : Boolean;
+ Flag67 : Boolean;
+ Flag68 : Boolean;
+ Flag69 : Boolean;
+ Flag70 : Boolean;
+ Flag71 : Boolean;
+ Flag72 : Boolean;
+ end record;
+
+ pragma Pack (Flag_Byte);
+ for Flag_Byte'Size use 8;
+
+ type Flag_Byte_Ptr is access all Flag_Byte;
+ type Node_Kind_Ptr is access all Node_Kind;
+
+ function To_Flag_Byte is new
+ Unchecked_Conversion (Node_Kind, Flag_Byte);
+
+ function To_Flag_Byte_Ptr is new
+ Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte_Ptr);
+
+ -- The following declarations are used to store flags 73-96 in the
+ -- Field12 field of the third component of an extended (entity) node.
+
+ type Flag_Word is record
+ Flag73 : Boolean;
+ Flag74 : Boolean;
+ Flag75 : Boolean;
+ Flag76 : Boolean;
+ Flag77 : Boolean;
+ Flag78 : Boolean;
+ Flag79 : Boolean;
+ Flag80 : Boolean;
+
+ Flag81 : Boolean;
+ Flag82 : Boolean;
+ Flag83 : Boolean;
+ Flag84 : Boolean;
+ Flag85 : Boolean;
+ Flag86 : Boolean;
+ Flag87 : Boolean;
+ Flag88 : Boolean;
+
+ Flag89 : Boolean;
+ Flag90 : Boolean;
+ Flag91 : Boolean;
+ Flag92 : Boolean;
+ Flag93 : Boolean;
+ Flag94 : Boolean;
+ Flag95 : Boolean;
+ Flag96 : Boolean;
+
+ Convention : Convention_Id;
+ end record;
+
+ pragma Pack (Flag_Word);
+ for Flag_Word'Size use 32;
+ for Flag_Word'Alignment use 4;
+
+ type Flag_Word_Ptr is access all Flag_Word;
+ type Union_Id_Ptr is access all Union_Id;
+
+ function To_Flag_Word is new
+ Unchecked_Conversion (Union_Id, Flag_Word);
+
+ function To_Flag_Word_Ptr is new
+ Unchecked_Conversion (Union_Id_Ptr, Flag_Word_Ptr);
+
+ -- The following declarations are used to store flags 97-128 in the
+ -- Field12 field of the fourth component of an extended (entity) node.
+
+ type Flag_Word2 is record
+ Flag97 : Boolean;
+ Flag98 : Boolean;
+ Flag99 : Boolean;
+ Flag100 : Boolean;
+ Flag101 : Boolean;
+ Flag102 : Boolean;
+ Flag103 : Boolean;
+ Flag104 : Boolean;
+
+ Flag105 : Boolean;
+ Flag106 : Boolean;
+ Flag107 : Boolean;
+ Flag108 : Boolean;
+ Flag109 : Boolean;
+ Flag110 : Boolean;
+ Flag111 : Boolean;
+ Flag112 : Boolean;
+
+ Flag113 : Boolean;
+ Flag114 : Boolean;
+ Flag115 : Boolean;
+ Flag116 : Boolean;
+ Flag117 : Boolean;
+ Flag118 : Boolean;
+ Flag119 : Boolean;
+ Flag120 : Boolean;
+
+ Flag121 : Boolean;
+ Flag122 : Boolean;
+ Flag123 : Boolean;
+ Flag124 : Boolean;
+ Flag125 : Boolean;
+ Flag126 : Boolean;
+ Flag127 : Boolean;
+ Flag128 : Boolean;
+ end record;
+
+ pragma Pack (Flag_Word2);
+ for Flag_Word2'Size use 32;
+ for Flag_Word2'Alignment use 4;
+
+ type Flag_Word2_Ptr is access all Flag_Word2;
+
+ function To_Flag_Word2 is new
+ Unchecked_Conversion (Union_Id, Flag_Word2);
+
+ function To_Flag_Word2_Ptr is new
+ Unchecked_Conversion (Union_Id_Ptr, Flag_Word2_Ptr);
+
+ -- The following declarations are used to store flags 97-120 in the
+ -- Field12 field of the fourth component of an extended (entity) node.
+
+ type Flag_Word3 is record
+ Flag152 : Boolean;
+ Flag153 : Boolean;
+ Flag154 : Boolean;
+ Flag155 : Boolean;
+ Flag156 : Boolean;
+ Flag157 : Boolean;
+ Flag158 : Boolean;
+ Flag159 : Boolean;
+
+ Flag160 : Boolean;
+ Flag161 : Boolean;
+ Flag162 : Boolean;
+ Flag163 : Boolean;
+ Flag164 : Boolean;
+ Flag165 : Boolean;
+ Flag166 : Boolean;
+ Flag167 : Boolean;
+
+ Flag168 : Boolean;
+ Flag169 : Boolean;
+ Flag170 : Boolean;
+ Flag171 : Boolean;
+ Flag172 : Boolean;
+ Flag173 : Boolean;
+ Flag174 : Boolean;
+ Flag175 : Boolean;
+
+ Flag176 : Boolean;
+ Flag177 : Boolean;
+ Flag178 : Boolean;
+ Flag179 : Boolean;
+ Flag180 : Boolean;
+ Flag181 : Boolean;
+ Flag182 : Boolean;
+ Flag183 : Boolean;
+ end record;
+
+ pragma Pack (Flag_Word3);
+ for Flag_Word3'Size use 32;
+ for Flag_Word3'Alignment use 4;
+
+ type Flag_Word3_Ptr is access all Flag_Word3;
+
+ function To_Flag_Word3 is new
+ Unchecked_Conversion (Union_Id, Flag_Word3);
+
+ function To_Flag_Word3_Ptr is new
+ Unchecked_Conversion (Union_Id_Ptr, Flag_Word3_Ptr);
+
+ -- Default value used to initialize default nodes. Note that some of the
+ -- fields get overwritten, and in particular, Nkind always gets reset.
+
+ Default_Node : Node_Record := (
+ Is_Extension => False,
+ Pflag1 => False,
+ Pflag2 => False,
+ In_List => False,
+ Unused_1 => False,
+ Rewrite_Ins => False,
+ Analyzed => False,
+ Comes_From_Source => False, -- modified by Set_Comes_From_Source_Default
+ Error_Posted => False,
+ Flag4 => False,
+
+ Flag5 => False,
+ Flag6 => False,
+ Flag7 => False,
+ Flag8 => False,
+ Flag9 => False,
+ Flag10 => False,
+ Flag11 => False,
+ Flag12 => False,
+
+ Flag13 => False,
+ Flag14 => False,
+ Flag15 => False,
+ Flag16 => False,
+ Flag17 => False,
+ Flag18 => False,
+
+ Nkind => N_Unused_At_Start,
+
+ Sloc => No_Location,
+ Link => Empty_List_Or_Node,
+ Field1 => Empty_List_Or_Node,
+ Field2 => Empty_List_Or_Node,
+ Field3 => Empty_List_Or_Node,
+ Field4 => Empty_List_Or_Node,
+ Field5 => Empty_List_Or_Node);
+
+ -- Default value used to initialize node extensions (i.e. the second
+ -- and third and fourth components of an extended node). Note we are
+ -- cheating a bit here when it comes to Node12, which really holds
+ -- flags an (for the third component), the convention. But it works
+ -- because Empty, False, Convention_Ada, all happen to be all zero bits.
+
+ Default_Node_Extension : constant Node_Record := (
+ Is_Extension => True,
+ Pflag1 => False,
+ Pflag2 => False,
+ In_List => False,
+ Unused_1 => False,
+ Rewrite_Ins => False,
+ Analyzed => False,
+ Comes_From_Source => False,
+ Error_Posted => False,
+ Flag4 => False,
+
+ Flag5 => False,
+ Flag6 => False,
+ Flag7 => False,
+ Flag8 => False,
+ Flag9 => False,
+ Flag10 => False,
+ Flag11 => False,
+ Flag12 => False,
+
+ Flag13 => False,
+ Flag14 => False,
+ Flag15 => False,
+ Flag16 => False,
+ Flag17 => False,
+ Flag18 => False,
+
+ Nkind => E_To_N (E_Void),
+
+ Field6 => Empty_List_Or_Node,
+ Field7 => Empty_List_Or_Node,
+ Field8 => Empty_List_Or_Node,
+ Field9 => Empty_List_Or_Node,
+ Field10 => Empty_List_Or_Node,
+ Field11 => Empty_List_Or_Node,
+ Field12 => Empty_List_Or_Node);
+
+ --------------------------------------------------
+ -- Implementation of Tree Substitution Routines --
+ --------------------------------------------------
+
+ -- A separate table keeps track of the mapping between rewritten nodes
+ -- and their corresponding original tree nodes. Rewrite makes an entry
+ -- in this table for use by Original_Node. By default, if no call is
+ -- Rewrite, the entry in this table points to the original unwritten node.
+
+ -- Note: eventually, this should be a field in the Node directly, but
+ -- for now we do not want to disturb the efficiency of a power of 2
+ -- for the node size
+
+ package Orig_Nodes is new Table.Table (
+ Table_Component_Type => Node_Id,
+ Table_Index_Type => Node_Id,
+ Table_Low_Bound => First_Node_Id,
+ Table_Initial => Alloc.Orig_Nodes_Initial,
+ Table_Increment => Alloc.Orig_Nodes_Increment,
+ Table_Name => "Orig_Nodes");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id);
+ -- This subprogram is used to fixup parent pointers that are rendered
+ -- incorrect because of a node copy. Field is checked to see if it
+ -- points to a node, list, or element list that has a parent that
+ -- points to Old_Node. If so, the parent is reset to point to New_Node.
+
+ --------------
+ -- Analyzed --
+ --------------
+
+ function Analyzed (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Analyzed;
+ end Analyzed;
+
+ -----------------
+ -- Change_Node --
+ -----------------
+
+ procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is
+ Save_Sloc : constant Source_Ptr := Sloc (N);
+ Save_In_List : constant Boolean := Nodes.Table (N).In_List;
+ Save_Link : constant Union_Id := Nodes.Table (N).Link;
+ Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source;
+ Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted;
+ Par_Count : Paren_Count_Type := 0;
+
+ begin
+ if Nkind (N) in N_Subexpr then
+ Par_Count := Paren_Count (N);
+ end if;
+
+ Nodes.Table (N) := Default_Node;
+ Nodes.Table (N).Sloc := Save_Sloc;
+ Nodes.Table (N).In_List := Save_In_List;
+ Nodes.Table (N).Link := Save_Link;
+ Nodes.Table (N).Comes_From_Source := Save_CFS;
+ Nodes.Table (N).Nkind := New_Node_Kind;
+ Nodes.Table (N).Error_Posted := Save_Posted;
+
+ if New_Node_Kind in N_Subexpr then
+ Set_Paren_Count (N, Par_Count);
+ end if;
+ end Change_Node;
+
+ -----------------------
+ -- Comes_From_Source --
+ -----------------------
+
+ function Comes_From_Source (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Comes_From_Source;
+ end Comes_From_Source;
+
+ ----------------
+ -- Convention --
+ ----------------
+
+ function Convention (E : Entity_Id) return Convention_Id is
+ begin
+ pragma Assert (Nkind (E) in N_Entity);
+ return To_Flag_Word (Nodes.Table (E + 2).Field12).Convention;
+ end Convention;
+
+ ---------------
+ -- Copy_Node --
+ ---------------
+
+ procedure Copy_Node (Source : Node_Id; Destination : Node_Id) is
+ Save_In_List : constant Boolean := Nodes.Table (Destination).In_List;
+ Save_Link : constant Union_Id := Nodes.Table (Destination).Link;
+
+ begin
+ Nodes.Table (Destination) := Nodes.Table (Source);
+ Nodes.Table (Destination).In_List := Save_In_List;
+ Nodes.Table (Destination).Link := Save_Link;
+
+ if Has_Extension (Source) then
+ pragma Assert (Has_Extension (Destination));
+ Nodes.Table (Destination + 1) := Nodes.Table (Source + 1);
+ Nodes.Table (Destination + 2) := Nodes.Table (Source + 2);
+ Nodes.Table (Destination + 3) := Nodes.Table (Source + 3);
+
+ else
+ pragma Assert (not Has_Extension (Source));
+ null;
+ end if;
+ end Copy_Node;
+
+ ------------------------
+ -- Copy_Separate_Tree --
+ ------------------------
+
+ function Copy_Separate_Tree (Source : Node_Id) return Node_Id is
+ New_Id : Node_Id;
+
+ function Copy_Entity (E : Entity_Id) return Entity_Id;
+ -- Copy Entity, copying only the Ekind and Chars fields
+
+ function Copy_List (List : List_Id) return List_Id;
+ -- Copy list
+
+ function Possible_Copy (Field : Union_Id) return Union_Id;
+ -- Given a field, returns a copy of the node or list if its parent
+ -- is the current source node, and otherwise returns the input
+
+ -----------------
+ -- Copy_Entity --
+ -----------------
+
+ function Copy_Entity (E : Entity_Id) return Entity_Id is
+ New_Ent : Entity_Id;
+
+ begin
+ case N_Entity (Nkind (E)) is
+ when N_Defining_Identifier =>
+ New_Ent := New_Entity (N_Defining_Identifier, Sloc (E));
+
+ when N_Defining_Character_Literal =>
+ New_Ent := New_Entity (N_Defining_Character_Literal, Sloc (E));
+
+ when N_Defining_Operator_Symbol =>
+ New_Ent := New_Entity (N_Defining_Operator_Symbol, Sloc (E));
+ end case;
+
+ Set_Chars (New_Ent, Chars (E));
+ return New_Ent;
+ end Copy_Entity;
+
+ ---------------
+ -- Copy_List --
+ ---------------
+
+ function Copy_List (List : List_Id) return List_Id is
+ NL : List_Id;
+ E : Node_Id;
+
+ begin
+ if List = No_List then
+ return No_List;
+
+ else
+ NL := New_List;
+ E := First (List);
+
+ while Present (E) loop
+
+ if Has_Extension (E) then
+ Append (Copy_Entity (E), NL);
+ else
+ Append (Copy_Separate_Tree (E), NL);
+ end if;
+
+ Next (E);
+ end loop;
+
+ return NL;
+ end if;
+
+ end Copy_List;
+
+ -------------------
+ -- Possible_Copy --
+ -------------------
+
+ function Possible_Copy (Field : Union_Id) return Union_Id is
+ New_N : Union_Id;
+
+ begin
+ if Field in Node_Range then
+
+ New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field)));
+
+ if Parent (Node_Id (Field)) = Source then
+ Set_Parent (Node_Id (New_N), New_Id);
+ end if;
+
+ return New_N;
+
+ elsif Field in List_Range then
+ New_N := Union_Id (Copy_List (List_Id (Field)));
+
+ if Parent (List_Id (Field)) = Source then
+ Set_Parent (List_Id (New_N), New_Id);
+ end if;
+
+ return New_N;
+
+ else
+ return Field;
+ end if;
+ end Possible_Copy;
+
+ -- Start of processing for Copy_Separate_Tree
+
+ begin
+ if Source <= Empty_Or_Error then
+ return Source;
+
+ elsif Has_Extension (Source) then
+ return Copy_Entity (Source);
+
+ else
+ Nodes.Increment_Last;
+ New_Id := Nodes.Last;
+ Nodes.Table (New_Id) := Nodes.Table (Source);
+ Nodes.Table (New_Id).Link := Empty_List_Or_Node;
+ Nodes.Table (New_Id).In_List := False;
+ Nodes.Table (New_Id).Rewrite_Ins := False;
+ Node_Count := Node_Count + 1;
+
+ Orig_Nodes.Increment_Last;
+ Allocate_List_Tables (Nodes.Last);
+ Orig_Nodes.Table (New_Id) := New_Id;
+
+ -- Recursively copy descendents
+
+ Set_Field1 (New_Id, Possible_Copy (Field1 (New_Id)));
+ Set_Field2 (New_Id, Possible_Copy (Field2 (New_Id)));
+ Set_Field3 (New_Id, Possible_Copy (Field3 (New_Id)));
+ Set_Field4 (New_Id, Possible_Copy (Field4 (New_Id)));
+ Set_Field5 (New_Id, Possible_Copy (Field5 (New_Id)));
+
+ -- Set Entity field to Empty
+ -- Why is this done??? and why is it always right to do it???
+
+ if Nkind (New_Id) in N_Has_Entity
+ or else Nkind (New_Id) = N_Freeze_Entity
+ then
+ Set_Entity (New_Id, Empty);
+ end if;
+
+ -- All done, return copied node
+
+ return New_Id;
+ end if;
+ end Copy_Separate_Tree;
+
+ -----------------
+ -- Delete_Node --
+ -----------------
+
+ procedure Delete_Node (Node : Node_Id) is
+ begin
+ pragma Assert (not Nodes.Table (Node).In_List);
+
+ if Debug_Flag_N then
+ Write_Str ("Delete node ");
+ Write_Int (Int (Node));
+ Write_Eol;
+ end if;
+
+ Nodes.Table (Node) := Default_Node;
+ Nodes.Table (Node).Nkind := N_Unused_At_Start;
+ Node_Count := Node_Count - 1;
+
+ -- Note: for now, we are not bothering to reuse deleted nodes
+
+ end Delete_Node;
+
+ -----------------
+ -- Delete_Tree --
+ -----------------
+
+ procedure Delete_Tree (Node : Node_Id) is
+
+ procedure Delete_Field (F : Union_Id);
+ -- Delete item pointed to by field F if it is a syntactic element
+
+ procedure Delete_List (L : List_Id);
+ -- Delete all elements on the given list
+
+ procedure Delete_Field (F : Union_Id) is
+ begin
+ if F = Union_Id (Empty) then
+ return;
+
+ elsif F in Node_Range
+ and then Parent (Node_Id (F)) = Node
+ then
+ Delete_Tree (Node_Id (F));
+
+ elsif F in List_Range
+ and then Parent (List_Id (F)) = Node
+ then
+ Delete_List (List_Id (F));
+
+ -- No need to test Elist case, there are no syntactic Elists
+
+ else
+ return;
+ end if;
+ end Delete_Field;
+
+ procedure Delete_List (L : List_Id) is
+ begin
+ while Is_Non_Empty_List (L) loop
+ Delete_Tree (Remove_Head (L));
+ end loop;
+ end Delete_List;
+
+ -- Start of processing for Delete_Tree
+
+ begin
+ -- Delete descendents
+
+ Delete_Field (Field1 (Node));
+ Delete_Field (Field2 (Node));
+ Delete_Field (Field3 (Node));
+ Delete_Field (Field4 (Node));
+ Delete_Field (Field5 (Node));
+
+ end Delete_Tree;
+
+ -----------
+ -- Ekind --
+ -----------
+
+ function Ekind (E : Entity_Id) return Entity_Kind is
+ begin
+ pragma Assert (Nkind (E) in N_Entity);
+ return N_To_E (Nodes.Table (E + 1).Nkind);
+ end Ekind;
+
+ ------------------
+ -- Error_Posted --
+ ------------------
+
+ function Error_Posted (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Error_Posted;
+ end Error_Posted;
+
+ -----------------------
+ -- Exchange_Entities --
+ -----------------------
+
+ procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is
+ Temp_Ent : Node_Record;
+
+ begin
+ pragma Assert (Has_Extension (E1)
+ and then Has_Extension (E2)
+ and then not Nodes.Table (E1).In_List
+ and then not Nodes.Table (E2).In_List);
+
+ -- Exchange the contents of the two entities
+
+ Temp_Ent := Nodes.Table (E1);
+ Nodes.Table (E1) := Nodes.Table (E2);
+ Nodes.Table (E2) := Temp_Ent;
+ Temp_Ent := Nodes.Table (E1 + 1);
+ Nodes.Table (E1 + 1) := Nodes.Table (E2 + 1);
+ Nodes.Table (E2 + 1) := Temp_Ent;
+ Temp_Ent := Nodes.Table (E1 + 2);
+ Nodes.Table (E1 + 2) := Nodes.Table (E2 + 2);
+ Nodes.Table (E2 + 2) := Temp_Ent;
+ Temp_Ent := Nodes.Table (E1 + 3);
+ Nodes.Table (E1 + 3) := Nodes.Table (E2 + 3);
+ Nodes.Table (E2 + 3) := Temp_Ent;
+
+ -- That exchange exchanged the parent pointers as well, which is what
+ -- we want, but we need to patch up the defining identifier pointers
+ -- in the parent nodes (the child pointers) to match this switch
+ -- unless for Implicit types entities which have no parent, in which
+ -- case we don't do anything otherwise we won't be able to revert back
+ -- to the original situation.
+
+ -- Shouldn't this use Is_Itype instead of the Parent test
+
+ if Present (Parent (E1)) and then Present (Parent (E2)) then
+ Set_Defining_Identifier (Parent (E1), E1);
+ Set_Defining_Identifier (Parent (E2), E2);
+ end if;
+ end Exchange_Entities;
+
+ -----------------
+ -- Extend_Node --
+ -----------------
+
+ function Extend_Node (Node : Node_Id) return Entity_Id is
+ Result : Entity_Id;
+
+ procedure Debug_Extend_Node;
+ -- Debug routine for debug flag N
+
+ procedure Debug_Extend_Node is
+ begin
+ if Debug_Flag_N then
+ Write_Str ("Extend node ");
+ Write_Int (Int (Node));
+
+ if Result = Node then
+ Write_Str (" in place");
+ else
+ Write_Str (" copied to ");
+ Write_Int (Int (Result));
+ end if;
+
+ -- Write_Eol;
+ end if;
+ end Debug_Extend_Node;
+
+ pragma Inline (Debug_Extend_Node);
+
+ begin
+ if Node /= Nodes.Last then
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Nodes.Table (Node);
+ Result := Nodes.Last;
+
+ Orig_Nodes.Increment_Last;
+ Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
+
+ else
+ Result := Node;
+ end if;
+
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+
+ Orig_Nodes.Set_Last (Nodes.Last);
+ Allocate_List_Tables (Nodes.Last);
+
+ pragma Debug (Debug_Extend_Node);
+ return Result;
+ end Extend_Node;
+
+ ----------------
+ -- Fix_Parent --
+ ----------------
+
+ procedure Fix_Parent (Field : Union_Id; Old_Node, New_Node : Node_Id) is
+ begin
+ -- Fix parent of node that is referenced by Field. Note that we must
+ -- exclude the case where the node is a member of a list, because in
+ -- this case the parent is the parent of the list.
+
+ if Field in Node_Range
+ and then Present (Node_Id (Field))
+ and then not Nodes.Table (Node_Id (Field)).In_List
+ and then Parent (Node_Id (Field)) = Old_Node
+ then
+ Set_Parent (Node_Id (Field), New_Node);
+
+ -- Fix parent of list that is referenced by Field
+
+ elsif Field in List_Range
+ and then Present (List_Id (Field))
+ and then Parent (List_Id (Field)) = Old_Node
+ then
+ Set_Parent (List_Id (Field), New_Node);
+ end if;
+
+ end Fix_Parent;
+
+ -----------------------------------
+ -- Get_Comes_From_Source_Default --
+ -----------------------------------
+
+ function Get_Comes_From_Source_Default return Boolean is
+ begin
+ return Default_Node.Comes_From_Source;
+ end Get_Comes_From_Source_Default;
+
+ -------------------
+ -- Has_Extension --
+ -------------------
+
+ function Has_Extension (N : Node_Id) return Boolean is
+ begin
+ return N < Nodes.Last and then Nodes.Table (N + 1).Is_Extension;
+ end Has_Extension;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ Dummy : Node_Id;
+
+ begin
+ -- Allocate Empty and Error nodes
+
+ Dummy := New_Node (N_Empty, No_Location);
+ Set_Name1 (Empty, No_Name);
+ Dummy := New_Node (N_Error, No_Location);
+ Set_Name1 (Error, Error_Name);
+
+ end Initialize;
+
+ --------------------------
+ -- Is_Rewrite_Insertion --
+ --------------------------
+
+ function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is
+ begin
+ return Nodes.Table (Node).Rewrite_Ins;
+ end Is_Rewrite_Insertion;
+
+ -----------------------------
+ -- Is_Rewrite_Substitution --
+ -----------------------------
+
+ function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is
+ begin
+ return Orig_Nodes.Table (Node) /= Node;
+ end Is_Rewrite_Substitution;
+
+ ------------------
+ -- Last_Node_Id --
+ ------------------
+
+ function Last_Node_Id return Node_Id is
+ begin
+ return Nodes.Last;
+ end Last_Node_Id;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock is
+ begin
+ Nodes.Locked := True;
+ Orig_Nodes.Locked := True;
+ Nodes.Release;
+ Orig_Nodes.Release;
+ end Lock;
+
+ ----------------------------
+ -- Mark_Rewrite_Insertion --
+ ----------------------------
+
+ procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is
+ begin
+ Nodes.Table (New_Node).Rewrite_Ins := True;
+ end Mark_Rewrite_Insertion;
+
+ --------------
+ -- New_Copy --
+ --------------
+
+ function New_Copy (Source : Node_Id) return Node_Id is
+ New_Id : Node_Id;
+
+ begin
+ if Source <= Empty_Or_Error then
+ return Source;
+
+ else
+ Nodes.Increment_Last;
+ New_Id := Nodes.Last;
+ Nodes.Table (New_Id) := Nodes.Table (Source);
+ Nodes.Table (New_Id).Link := Empty_List_Or_Node;
+ Nodes.Table (New_Id).In_List := False;
+ Nodes.Table (New_Id).Rewrite_Ins := False;
+
+ Orig_Nodes.Increment_Last;
+ Orig_Nodes.Table (New_Id) := New_Id;
+
+ if Has_Extension (Source) then
+ Nodes.Increment_Last;
+ Nodes.Table (New_Id + 1) := Nodes.Table (Source + 1);
+ Nodes.Increment_Last;
+ Nodes.Table (New_Id + 2) := Nodes.Table (Source + 2);
+ Nodes.Increment_Last;
+ Nodes.Table (New_Id + 3) := Nodes.Table (Source + 3);
+
+ Orig_Nodes.Set_Last (Nodes.Last);
+ end if;
+
+ Allocate_List_Tables (Nodes.Last);
+ Node_Count := Node_Count + 1;
+ return New_Id;
+ end if;
+ end New_Copy;
+
+ -------------------
+ -- New_Copy_Tree --
+ -------------------
+
+ -- Our approach here requires a two pass traversal of the tree. The
+ -- first pass visits all nodes that eventually will be copied looking
+ -- for defining Itypes. If any defining Itypes are found, then they are
+ -- copied, and an entry is added to the replacement map. In the second
+ -- phase, the tree is copied, using the replacement map to replace any
+ -- Itype references within the copied tree.
+
+ -- The following hash tables are used if the Map supplied has more
+ -- than hash threshhold entries to speed up access to the map. If
+ -- there are fewer entries, then the map is searched sequentially
+ -- (because setting up a hash table for only a few entries takes
+ -- more time than it saves.
+
+ -- Global variables are safe for this purpose, since there is no case
+ -- of a recursive call from the processing inside New_Copy_Tree.
+
+ NCT_Hash_Threshhold : constant := 20;
+ -- If there are more than this number of pairs of entries in the
+ -- map, then Hash_Tables_Used will be set, and the hash tables will
+ -- be initialized and used for the searches.
+
+ NCT_Hash_Tables_Used : Boolean := False;
+ -- Set to True if hash tables are in use
+
+ NCT_Table_Entries : Nat;
+ -- Count entries in table to see if threshhold is reached
+
+ NCT_Hash_Table_Setup : Boolean := False;
+ -- Set to True if hash table contains data. We set this True if we
+ -- setup the hash table with data, and leave it set permanently
+ -- from then on, this is a signal that second and subsequent users
+ -- of the hash table must clear the old entries before reuse.
+
+ subtype NCT_Header_Num is Int range 0 .. 511;
+ -- Defines range of headers in hash tables (512 headers)
+
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
+ -- Hash function used for hash operations
+
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
+ begin
+ return Nat (E) mod (NCT_Header_Num'Last + 1);
+ end New_Copy_Hash;
+
+ -- The hash table NCT_Assoc associates old entities in the table
+ -- with their corresponding new entities (i.e. the pairs of entries
+ -- presented in the original Map argument are Key-Element pairs).
+
+ package NCT_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
+
+ -- The hash table NCT_Itype_Assoc contains entries only for those
+ -- old nodes which have a non-empty Associated_Node_For_Itype set.
+ -- The key is the associated node, and the element is the new node
+ -- itself (NOT the associated node for the new node).
+
+ package NCT_Itype_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
+
+ -- Start of New_Copy_Tree function
+
+ function New_Copy_Tree
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty)
+ return Node_Id
+ is
+ Actual_Map : Elist_Id := Map;
+ -- This is the actual map for the copy. It is initialized with the
+ -- given elements, and then enlarged as required for Itypes that are
+ -- copied during the first phase of the copy operation. The visit
+ -- procedures add elements to this map as Itypes are encountered.
+ -- The reason we cannot use Map directly, is that it may well be
+ -- (and normally is) initialized to No_Elist, and if we have mapped
+ -- entities, we have to reset it to point to a real Elist.
+
+ function Assoc (N : Node_Or_Entity_Id) return Node_Id;
+ -- Called during second phase to map entities into their corresponding
+ -- copies using Actual_Map. If the argument is not an entity, or is not
+ -- in Actual_Map, then it is returned unchanged.
+
+ procedure Build_NCT_Hash_Tables;
+ -- Builds hash tables (number of elements >= threshold value)
+
+ function Copy_Elist_With_Replacement
+ (Old_Elist : Elist_Id)
+ return Elist_Id;
+ -- Called during second phase to copy element list doing replacements.
+
+ procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
+ -- Called during the second phase to process a copied Itype. The actual
+ -- copy happened during the first phase (so that we could make the entry
+ -- in the mapping), but we still have to deal with the descendents of
+ -- the copied Itype and copy them where necessary.
+
+ function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
+ -- Called during second phase to copy list doing replacements.
+
+ function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
+ -- Called during second phase to copy node doing replacements
+
+ procedure Visit_Elist (E : Elist_Id);
+ -- Called during first phase to visit all elements of an Elist
+
+ procedure Visit_Field (F : Union_Id; N : Node_Id);
+ -- Visit a single field, recursing to call Visit_Node or Visit_List
+ -- if the field is a syntactic descendent of the current node (i.e.
+ -- its parent is Node N).
+
+ procedure Visit_Itype (Old_Itype : Entity_Id);
+ -- Called during first phase to visit subsidiary fields of a defining
+ -- Itype, and also create a copy and make an entry in the replacement
+ -- map for the new copy.
+
+ procedure Visit_List (L : List_Id);
+ -- Called during first phase to visit all elements of a List
+
+ procedure Visit_Node (N : Node_Or_Entity_Id);
+ -- Called during first phase to visit a node and all its subtrees
+
+ -----------
+ -- Assoc --
+ -----------
+
+ function Assoc (N : Node_Or_Entity_Id) return Node_Id is
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ if not Has_Extension (N) or else No (Actual_Map) then
+ return N;
+
+ elsif NCT_Hash_Tables_Used then
+ Ent := NCT_Assoc.Get (Entity_Id (N));
+
+ if Present (Ent) then
+ return Ent;
+ else
+ return N;
+ end if;
+
+ -- No hash table used, do serial search
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Node (E) = N then
+ return Node (Next_Elmt (E));
+ else
+ E := Next_Elmt (Next_Elmt (E));
+ end if;
+ end loop;
+ end if;
+
+ return N;
+ end Assoc;
+
+ ---------------------------
+ -- Build_NCT_Hash_Tables --
+ ---------------------------
+
+ procedure Build_NCT_Hash_Tables is
+ Elmt : Elmt_Id;
+ Ent : Entity_Id;
+ begin
+ if NCT_Hash_Table_Setup then
+ NCT_Assoc.Reset;
+ NCT_Itype_Assoc.Reset;
+ end if;
+
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+ Next_Elmt (Elmt);
+ NCT_Assoc.Set (Ent, Node (Elmt));
+ Next_Elmt (Elmt);
+
+ if Is_Type (Ent) then
+ declare
+ Anode : constant Entity_Id :=
+ Associated_Node_For_Itype (Ent);
+
+ begin
+ if Present (Anode) then
+ NCT_Itype_Assoc.Set (Anode, Node (Elmt));
+ end if;
+ end;
+ end if;
+ end loop;
+
+ NCT_Hash_Tables_Used := True;
+ NCT_Hash_Table_Setup := True;
+ end Build_NCT_Hash_Tables;
+
+ ---------------------------------
+ -- Copy_Elist_With_Replacement --
+ ---------------------------------
+
+ function Copy_Elist_With_Replacement
+ (Old_Elist : Elist_Id)
+ return Elist_Id
+ is
+ M : Elmt_Id;
+ New_Elist : Elist_Id;
+
+ begin
+ if No (Old_Elist) then
+ return No_Elist;
+
+ else
+ New_Elist := New_Elmt_List;
+ M := First_Elmt (Old_Elist);
+
+ while Present (M) loop
+ Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
+ Next_Elmt (M);
+ end loop;
+ end if;
+
+ return New_Elist;
+ end Copy_Elist_With_Replacement;
+
+ ---------------------------------
+ -- Copy_Itype_With_Replacement --
+ ---------------------------------
+
+ -- This routine exactly parallels its phase one analog Visit_Itype,
+ -- and like that routine, knows far too many semantic details about
+ -- the descendents of Itypes and whether they need copying or not.
+
+ procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
+ begin
+ -- Translate Next_Entity, Scope and Etype fields, in case they
+ -- reference entities that have been mapped into copies.
+
+ Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
+ Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
+
+ if Present (New_Scope) then
+ Set_Scope (New_Itype, New_Scope);
+ else
+ Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
+ end if;
+
+ -- Copy referenced fields
+
+ if Is_Discrete_Type (New_Itype) then
+ Set_Scalar_Range (New_Itype,
+ Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
+
+ elsif Has_Discriminants (Base_Type (New_Itype)) then
+ Set_Discriminant_Constraint (New_Itype,
+ Copy_Elist_With_Replacement
+ (Discriminant_Constraint (New_Itype)));
+
+ elsif Is_Array_Type (New_Itype) then
+ if Present (First_Index (New_Itype)) then
+ Set_First_Index (New_Itype,
+ First (Copy_List_With_Replacement
+ (List_Containing (First_Index (New_Itype)))));
+ end if;
+
+ if Is_Packed (New_Itype) then
+ Set_Packed_Array_Type (New_Itype,
+ Copy_Node_With_Replacement
+ (Packed_Array_Type (New_Itype)));
+ end if;
+ end if;
+ end Copy_Itype_With_Replacement;
+
+ --------------------------------
+ -- Copy_List_With_Replacement --
+ --------------------------------
+
+ function Copy_List_With_Replacement
+ (Old_List : List_Id)
+ return List_Id
+ is
+ New_List : List_Id;
+ E : Node_Id;
+
+ begin
+ if Old_List = No_List then
+ return No_List;
+
+ else
+ New_List := Empty_List;
+ E := First (Old_List);
+ while Present (E) loop
+ Append (Copy_Node_With_Replacement (E), New_List);
+ Next (E);
+ end loop;
+
+ return New_List;
+ end if;
+ end Copy_List_With_Replacement;
+
+ --------------------------------
+ -- Copy_Node_With_Replacement --
+ --------------------------------
+
+ function Copy_Node_With_Replacement
+ (Old_Node : Node_Id)
+ return Node_Id
+ is
+ New_Node : Node_Id;
+
+ function Copy_Field_With_Replacement
+ (Field : Union_Id)
+ return Union_Id;
+ -- Given Field, which is a field of Old_Node, return a copy of it
+ -- if it is a syntactic field (i.e. its parent is Node), setting
+ -- the parent of the copy to poit to New_Node. Otherwise returns
+ -- the field (possibly mapped if it is an entity).
+
+ ---------------------------------
+ -- Copy_Field_With_Replacement --
+ ---------------------------------
+
+ function Copy_Field_With_Replacement
+ (Field : Union_Id)
+ return Union_Id
+ is
+ begin
+ if Field = Union_Id (Empty) then
+ return Field;
+
+ elsif Field in Node_Range then
+ declare
+ Old_N : constant Node_Id := Node_Id (Field);
+ New_N : Node_Id;
+
+ begin
+ -- If syntactic field, as indicated by the parent pointer
+ -- being set, then copy the referenced node recursively.
+
+ if Parent (Old_N) = Old_Node then
+ New_N := Copy_Node_With_Replacement (Old_N);
+
+ if New_N /= Old_N then
+ Set_Parent (New_N, New_Node);
+ end if;
+
+ -- For semantic fields, update possible entity reference
+ -- from the replacement map.
+
+ else
+ New_N := Assoc (Old_N);
+ end if;
+
+ return Union_Id (New_N);
+ end;
+
+ elsif Field in List_Range then
+ declare
+ Old_L : constant List_Id := List_Id (Field);
+ New_L : List_Id;
+
+ begin
+ -- If syntactic field, as indicated by the parent pointer,
+ -- then recursively copy the entire referenced list.
+
+ if Parent (Old_L) = Old_Node then
+ New_L := Copy_List_With_Replacement (Old_L);
+ Set_Parent (New_L, New_Node);
+
+ -- For semantic list, just returned unchanged
+
+ else
+ New_L := Old_L;
+ end if;
+
+ return Union_Id (New_L);
+ end;
+
+ -- Anything other than a list or a node is returned unchanged
+
+ else
+ return Field;
+ end if;
+ end Copy_Field_With_Replacement;
+
+ -- Start of processing for Copy_Node_With_Replacement
+
+ begin
+ if Old_Node <= Empty_Or_Error then
+ return Old_Node;
+
+ elsif Has_Extension (Old_Node) then
+ return Assoc (Old_Node);
+
+ else
+ Nodes.Increment_Last;
+ New_Node := Nodes.Last;
+ Nodes.Table (New_Node) := Nodes.Table (Old_Node);
+ Nodes.Table (New_Node).Link := Empty_List_Or_Node;
+ Nodes.Table (New_Node).In_List := False;
+ Node_Count := Node_Count + 1;
+
+ Orig_Nodes.Increment_Last;
+ Allocate_List_Tables (Nodes.Last);
+
+ Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
+
+ -- If the node we are copying is the associated node of a
+ -- previously copied Itype, then adjust the associated node
+ -- of the copy of that Itype accordingly.
+
+ if Present (Actual_Map) then
+ declare
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Case of hash table used
+
+ if NCT_Hash_Tables_Used then
+ Ent := NCT_Itype_Assoc.Get (Old_Node);
+
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Node);
+ end if;
+
+ -- Case of no hash table used
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Old_Node = Associated_Node_For_Itype (Node (E)) then
+ Set_Associated_Node_For_Itype
+ (Node (Next_Elmt (E)), New_Node);
+ end if;
+
+ E := Next_Elmt (Next_Elmt (E));
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Recursively copy descendents
+
+ Set_Field1
+ (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
+ Set_Field2
+ (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
+ Set_Field3
+ (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
+ Set_Field4
+ (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
+ Set_Field5
+ (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
+
+ -- If the original is marked as a rewrite insertion, then unmark
+ -- the copy, since we inserted the original, not the copy.
+
+ Nodes.Table (New_Node).Rewrite_Ins := False;
+
+ -- Adjust Sloc of new node if necessary
+
+ if New_Sloc /= No_Location then
+ Set_Sloc (New_Node, New_Sloc);
+
+ -- If we adjust the Sloc, then we are essentially making
+ -- a completely new node, so the Comes_From_Source flag
+ -- should be reset to the proper default value.
+
+ Nodes.Table (New_Node).Comes_From_Source :=
+ Default_Node.Comes_From_Source;
+ end if;
+
+ -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
+ -- The replacement mechanism applies to entities, and is not used
+ -- here. Eventually we may need a more general graph-copying
+ -- routine. For now, do a sequential search to find desired node.
+
+ if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
+ and then Present (First_Real_Statement (Old_Node))
+ then
+ declare
+ Old_F : constant Node_Id := First_Real_Statement (Old_Node);
+ N1, N2 : Node_Id;
+
+ begin
+ N1 := First (Statements (Old_Node));
+ N2 := First (Statements (New_Node));
+
+ while N1 /= Old_F loop
+ Next (N1);
+ Next (N2);
+ end loop;
+
+ Set_First_Real_Statement (New_Node, N2);
+ end;
+ end if;
+ end if;
+
+ -- All done, return copied node
+
+ return New_Node;
+ end Copy_Node_With_Replacement;
+
+ -----------------
+ -- Visit_Elist --
+ -----------------
+
+ procedure Visit_Elist (E : Elist_Id) is
+ Elmt : Elmt_Id;
+
+ begin
+ if Present (E) then
+ Elmt := First_Elmt (E);
+
+ while Elmt /= No_Elmt loop
+ Visit_Node (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end Visit_Elist;
+
+ -----------------
+ -- Visit_Field --
+ -----------------
+
+ procedure Visit_Field (F : Union_Id; N : Node_Id) is
+ begin
+ if F = Union_Id (Empty) then
+ return;
+
+ elsif F in Node_Range then
+
+ -- Copy node if it is syntactic, i.e. its parent pointer is
+ -- set to point to the field that referenced it (certain
+ -- Itypes will also meet this criterion, which is fine, since
+ -- these are clearly Itypes that do need to be copied, since
+ -- we are copying their parent.)
+
+ if Parent (Node_Id (F)) = N then
+ Visit_Node (Node_Id (F));
+ return;
+
+ -- Another case, if we are pointing to an Itype, then we want
+ -- to copy it if its associated node is somewhere in the tree
+ -- being copied.
+
+ -- Note: the exclusion of self-referential copies is just an
+ -- optimization, since the search of the already copied list
+ -- would catch it, but it is a common case (Etype pointing
+ -- to itself for an Itype that is a base type).
+
+ elsif Has_Extension (Node_Id (F))
+ and then Is_Itype (Entity_Id (F))
+ and then Node_Id (F) /= N
+ then
+ declare
+ P : Node_Id;
+
+ begin
+ P := Associated_Node_For_Itype (Node_Id (F));
+ while Present (P) loop
+ if P = Source then
+ Visit_Node (Node_Id (F));
+ return;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+
+ -- An Itype whose parent is not being copied definitely
+ -- should NOT be copied, since it does not belong in any
+ -- sense to the copied subtree.
+
+ return;
+ end;
+ end if;
+
+ elsif F in List_Range
+ and then Parent (List_Id (F)) = N
+ then
+ Visit_List (List_Id (F));
+ return;
+ end if;
+ end Visit_Field;
+
+ -----------------
+ -- Visit_Itype --
+ -----------------
+
+ -- Note: we are relying on far too much semantic knowledge in this
+ -- routine, it really should just do a blind replacement of all
+ -- fields, or at least a more blind replacement. For example, we
+ -- do not deal with corresponding record types, and that works
+ -- because we have no Itypes of task types, but nowhere is there
+ -- a guarantee that this will always be the case. ???
+
+ procedure Visit_Itype (Old_Itype : Entity_Id) is
+ New_Itype : Entity_Id;
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Itypes that describe the designated type of access to subprograms
+ -- have the structure of subprogram declarations, with signatures,
+ -- etc. Either we duplicate the signatures completely, or choose to
+ -- share such itypes, which is fine because their elaboration will
+ -- have no side effects. In any case, this is additional semantic
+ -- information that seems awkward to have in atree.
+
+ if Ekind (Old_Itype) = E_Subprogram_Type then
+ return;
+ end if;
+
+ New_Itype := New_Copy (Old_Itype);
+
+ -- If our associated node is an entity that has already been copied,
+ -- then set the associated node of the copy to point to the right
+ -- copy. If we have copied an Itype that is itself the associated
+ -- node of some previously copied Itype, then we set the right
+ -- pointer in the other direction.
+
+ if Present (Actual_Map) then
+
+ -- Case of hash tables used
+
+ if NCT_Hash_Tables_Used then
+
+ Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (New_Itype, Ent);
+ end if;
+
+ Ent := NCT_Itype_Assoc.Get (Old_Itype);
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Itype);
+ end if;
+
+ -- Csae of hash tables not used
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Associated_Node_For_Itype (Old_Itype) = Node (E) then
+ Set_Associated_Node_For_Itype
+ (New_Itype, Node (Next_Elmt (E)));
+ end if;
+
+ if Old_Itype = Associated_Node_For_Itype (Node (E)) then
+ Set_Associated_Node_For_Itype
+ (Node (Next_Elmt (E)), New_Itype);
+ end if;
+
+ E := Next_Elmt (Next_Elmt (E));
+ end loop;
+ end if;
+ end if;
+
+ if Present (Freeze_Node (New_Itype)) then
+ Set_Is_Frozen (New_Itype, False);
+ Set_Freeze_Node (New_Itype, Empty);
+ end if;
+
+ -- Add new association to map
+
+ if No (Actual_Map) then
+ Actual_Map := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Old_Itype, Actual_Map);
+ Append_Elmt (New_Itype, Actual_Map);
+
+ if NCT_Hash_Tables_Used then
+ NCT_Assoc.Set (Old_Itype, New_Itype);
+
+ else
+ NCT_Table_Entries := NCT_Table_Entries + 1;
+
+ if NCT_Table_Entries > NCT_Hash_Threshhold then
+ Build_NCT_Hash_Tables;
+ end if;
+ end if;
+
+ -- If a record subtype is simply copied, the entity list will be
+ -- shared. Thus cloned_Subtype must be set to indicate the sharing.
+
+ if Ekind (Old_Itype) = E_Record_Subtype
+ or else Ekind (Old_Itype) = E_Class_Wide_Subtype
+ then
+ Set_Cloned_Subtype (New_Itype, Old_Itype);
+ end if;
+
+ -- Visit descendents that eventually get copied
+
+ Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
+
+ if Is_Discrete_Type (Old_Itype) then
+ Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
+
+ elsif Has_Discriminants (Base_Type (Old_Itype)) then
+ -- ??? This should involve call to Visit_Field.
+ Visit_Elist (Discriminant_Constraint (Old_Itype));
+
+ elsif Is_Array_Type (Old_Itype) then
+ if Present (First_Index (Old_Itype)) then
+ Visit_Field (Union_Id (List_Containing
+ (First_Index (Old_Itype))),
+ Old_Itype);
+ end if;
+
+ if Is_Packed (Old_Itype) then
+ Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
+ Old_Itype);
+ end if;
+ end if;
+ end Visit_Itype;
+
+ ----------------
+ -- Visit_List --
+ ----------------
+
+ procedure Visit_List (L : List_Id) is
+ N : Node_Id;
+
+ begin
+ if L /= No_List then
+ N := First (L);
+
+ while Present (N) loop
+ Visit_Node (N);
+ Next (N);
+ end loop;
+ end if;
+ end Visit_List;
+
+ ----------------
+ -- Visit_Node --
+ ----------------
+
+ procedure Visit_Node (N : Node_Or_Entity_Id) is
+
+ -- Start of processing for Visit_Node
+
+ begin
+ -- Handle case of an Itype, which must be copied
+
+ if Has_Extension (N)
+ and then Is_Itype (N)
+ then
+ -- Nothing to do if already in the list. This can happen with an
+ -- Itype entity that appears more than once in the tree.
+ -- Note that we do not want to visit descendents in this case.
+
+ -- Test for already in list when hash table is used
+
+ if NCT_Hash_Tables_Used then
+ if Present (NCT_Assoc.Get (Entity_Id (N))) then
+ return;
+ end if;
+
+ -- Test for already in list when hash table not used
+
+ else
+ declare
+ E : Elmt_Id;
+
+ begin
+ if Present (Actual_Map) then
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Node (E) = N then
+ return;
+ else
+ E := Next_Elmt (Next_Elmt (E));
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Visit_Itype (N);
+ end if;
+
+ -- Visit descendents
+
+ Visit_Field (Field1 (N), N);
+ Visit_Field (Field2 (N), N);
+ Visit_Field (Field3 (N), N);
+ Visit_Field (Field4 (N), N);
+ Visit_Field (Field5 (N), N);
+ end Visit_Node;
+
+ -- Start of processing for New_Copy_Tree
+
+ begin
+ Actual_Map := Map;
+
+ -- See if we should use hash table
+
+ if No (Actual_Map) then
+ NCT_Hash_Tables_Used := False;
+
+ else
+ declare
+ Elmt : Elmt_Id;
+
+ begin
+ NCT_Table_Entries := 0;
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ NCT_Table_Entries := NCT_Table_Entries + 1;
+ Next_Elmt (Elmt);
+ Next_Elmt (Elmt);
+ end loop;
+
+ if NCT_Table_Entries > NCT_Hash_Threshhold then
+ Build_NCT_Hash_Tables;
+ else
+ NCT_Hash_Tables_Used := False;
+ end if;
+ end;
+ end if;
+
+ -- Hash table set up if required, now start phase one by visiting
+ -- top node (we will recursively visit the descendents).
+
+ Visit_Node (Source);
+
+ -- Now the second phase of the copy can start. First we process
+ -- all the mapped entities, copying their descendents.
+
+ if Present (Actual_Map) then
+ declare
+ Elmt : Elmt_Id;
+ New_Itype : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ Next_Elmt (Elmt);
+ New_Itype := Node (Elmt);
+ Copy_Itype_With_Replacement (New_Itype);
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ -- Now we can copy the actual tree
+
+ return Copy_Node_With_Replacement (Source);
+ end New_Copy_Tree;
+
+ ----------------
+ -- New_Entity --
+ ----------------
+
+ function New_Entity
+ (New_Node_Kind : Node_Kind;
+ New_Sloc : Source_Ptr)
+ return Entity_Id
+ is
+ procedure New_Entity_Debugging_Output;
+ -- Debugging routine for debug flag N
+
+ procedure New_Entity_Debugging_Output is
+ begin
+ if Debug_Flag_N then
+ Write_Str ("Allocate entity, Id = ");
+ Write_Int (Int (Nodes.Last));
+ Write_Str (" ");
+ Write_Location (New_Sloc);
+ Write_Str (" ");
+ Write_Str (Node_Kind'Image (New_Node_Kind));
+ Write_Eol;
+ end if;
+ end New_Entity_Debugging_Output;
+
+ pragma Inline (New_Entity_Debugging_Output);
+
+ -- Start of processing for New_Entity
+
+ begin
+ pragma Assert (New_Node_Kind in N_Entity);
+
+ Nodes.Increment_Last;
+ Current_Error_Node := Nodes.Last;
+ Nodes.Table (Nodes.Last) := Default_Node;
+ Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
+ Nodes.Table (Nodes.Last).Sloc := New_Sloc;
+ pragma Debug (New_Entity_Debugging_Output);
+
+ Orig_Nodes.Increment_Last;
+ Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
+
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node_Extension;
+
+ Orig_Nodes.Set_Last (Nodes.Last);
+ Allocate_List_Tables (Nodes.Last);
+ Node_Count := Node_Count + 1;
+ return Current_Error_Node;
+ end New_Entity;
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node
+ (New_Node_Kind : Node_Kind;
+ New_Sloc : Source_Ptr)
+ return Node_Id
+ is
+ procedure New_Node_Debugging_Output;
+ -- Debugging routine for debug flag N
+
+ procedure New_Node_Debugging_Output is
+ begin
+ if Debug_Flag_N then
+ Write_Str ("Allocate node, Id = ");
+ Write_Int (Int (Nodes.Last));
+ Write_Str (" ");
+ Write_Location (New_Sloc);
+ Write_Str (" ");
+ Write_Str (Node_Kind'Image (New_Node_Kind));
+ Write_Eol;
+ end if;
+ end New_Node_Debugging_Output;
+
+ pragma Inline (New_Node_Debugging_Output);
+
+ -- Start of processing for New_Node
+
+ begin
+ pragma Assert (New_Node_Kind not in N_Entity);
+ Nodes.Increment_Last;
+ Nodes.Table (Nodes.Last) := Default_Node;
+ Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
+ Nodes.Table (Nodes.Last).Sloc := New_Sloc;
+ pragma Debug (New_Node_Debugging_Output);
+ Current_Error_Node := Nodes.Last;
+ Node_Count := Node_Count + 1;
+
+ Orig_Nodes.Increment_Last;
+ Allocate_List_Tables (Nodes.Last);
+ Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
+ return Nodes.Last;
+ end New_Node;
+
+ -----------
+ -- Nkind --
+ -----------
+
+ function Nkind (N : Node_Id) return Node_Kind is
+ begin
+ return Nodes.Table (N).Nkind;
+ end Nkind;
+
+ --------
+ -- No --
+ --------
+
+ function No (N : Node_Id) return Boolean is
+ begin
+ return N = Empty;
+ end No;
+
+ -------------------
+ -- Nodes_Address --
+ -------------------
+
+ function Nodes_Address return System.Address is
+ begin
+ return Nodes.Table (First_Node_Id)'Address;
+ end Nodes_Address;
+
+ ---------------
+ -- Num_Nodes --
+ ---------------
+
+ function Num_Nodes return Nat is
+ begin
+ return Node_Count;
+ end Num_Nodes;
+
+ -------------------
+ -- Original_Node --
+ -------------------
+
+ function Original_Node (Node : Node_Id) return Node_Id is
+ begin
+ return Orig_Nodes.Table (Node);
+ end Original_Node;
+
+ -----------------
+ -- Paren_Count --
+ -----------------
+
+ function Paren_Count (N : Node_Id) return Paren_Count_Type is
+ C : Paren_Count_Type := 0;
+
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+
+ if Nodes.Table (N).Pflag1 then
+ C := C + 1;
+ end if;
+
+ if Nodes.Table (N).Pflag2 then
+ C := C + 2;
+ end if;
+
+ return C;
+ end Paren_Count;
+
+ ------------
+ -- Parent --
+ ------------
+
+ function Parent (N : Node_Id) return Node_Id is
+ begin
+ if Is_List_Member (N) then
+ return Parent (List_Containing (N));
+ else
+ return Node_Id (Nodes.Table (N).Link);
+ end if;
+ end Parent;
+
+ -------------
+ -- Present --
+ -------------
+
+ function Present (N : Node_Id) return Boolean is
+ begin
+ return N /= Empty;
+ end Present;
+
+ --------------------------------
+ -- Preserve_Comes_From_Source --
+ --------------------------------
+
+ procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is
+ begin
+ Nodes.Table (NewN).Comes_From_Source :=
+ Nodes.Table (OldN).Comes_From_Source;
+ end Preserve_Comes_From_Source;
+
+ -------------------
+ -- Relocate_Node --
+ -------------------
+
+ function Relocate_Node (Source : Node_Id) return Node_Id is
+ New_Node : Node_Id;
+
+ begin
+ if No (Source) then
+ return Empty;
+ end if;
+
+ New_Node := New_Copy (Source);
+ Fix_Parent (Field1 (Source), Source, New_Node);
+ Fix_Parent (Field2 (Source), Source, New_Node);
+ Fix_Parent (Field3 (Source), Source, New_Node);
+ Fix_Parent (Field4 (Source), Source, New_Node);
+ Fix_Parent (Field5 (Source), Source, New_Node);
+
+ -- We now set the parent of the new node to be the same as the
+ -- parent of the source. Almost always this parent will be
+ -- replaced by a new value when the relocated node is reattached
+ -- to the tree, but by doing it now, we ensure that this node is
+ -- not even temporarily disconnected from the tree. Note that this
+ -- does not happen free, because in the list case, the parent does
+ -- not get set.
+
+ Set_Parent (New_Node, Parent (Source));
+ return New_Node;
+ end Relocate_Node;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace (Old_Node, New_Node : Node_Id) is
+ Old_Link : constant Union_Id := Nodes.Table (Old_Node).Link;
+ Old_InL : constant Boolean := Nodes.Table (Old_Node).In_List;
+ Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
+ Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source;
+
+ begin
+ pragma Assert
+ (not Has_Extension (Old_Node)
+ and not Has_Extension (New_Node)
+ and not Nodes.Table (New_Node).In_List);
+
+ -- Do copy, preserving link and in list status and comes from source
+
+ Nodes.Table (Old_Node) := Nodes.Table (New_Node);
+ Nodes.Table (Old_Node).Link := Old_Link;
+ Nodes.Table (Old_Node).In_List := Old_InL;
+ Nodes.Table (Old_Node).Comes_From_Source := Old_CFS;
+ Nodes.Table (Old_Node).Error_Posted := Old_Post;
+
+ -- Fix parents of substituted node, since it has changed identity
+
+ Fix_Parent (Field1 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field2 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field3 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field4 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field5 (Old_Node), New_Node, Old_Node);
+
+ -- Since we are doing a replace, we assume that the original node
+ -- is intended to become the new replaced node. The call would be
+ -- to Rewrite_Substitute_Node if there were an intention to save
+ -- the original node.
+
+ Orig_Nodes.Table (Old_Node) := Old_Node;
+
+ -- Finally delete the source, since it is now copied
+
+ Delete_Node (New_Node);
+
+ end Replace;
+
+ -------------
+ -- Rewrite --
+ -------------
+
+ procedure Rewrite (Old_Node, New_Node : Node_Id) is
+
+ Old_Link : constant Union_Id := Nodes.Table (Old_Node).Link;
+ Old_In_List : constant Boolean := Nodes.Table (Old_Node).In_List;
+ Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
+ -- These three fields are always preserved in the new node
+
+ Old_Paren_Count : Paren_Count_Type;
+ Old_Must_Not_Freeze : Boolean;
+ -- These fields are preserved in the new node only if the new node
+ -- and the old node are both subexpression nodes.
+
+ -- Note: it is a violation of abstraction levels for Must_Not_Freeze
+ -- to be referenced like this. ???
+
+ Sav_Node : Node_Id;
+
+ begin
+ pragma Assert
+ (not Has_Extension (Old_Node)
+ and not Has_Extension (New_Node)
+ and not Nodes.Table (New_Node).In_List);
+
+ if Nkind (Old_Node) in N_Subexpr then
+ Old_Paren_Count := Paren_Count (Old_Node);
+ Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node);
+ else
+ Old_Paren_Count := 0;
+ Old_Must_Not_Freeze := False;
+ end if;
+
+ -- Allocate a new node, to be used to preserve the original contents
+ -- of the Old_Node, for possible later retrival by Original_Node and
+ -- make an entry in the Orig_Nodes table. This is only done if we have
+ -- not already rewritten the node, as indicated by an Orig_Nodes entry
+ -- that does not reference the Old_Node.
+
+ if Orig_Nodes.Table (Old_Node) = Old_Node then
+ Nodes.Increment_Last;
+ Sav_Node := Nodes.Last;
+ Nodes.Table (Sav_Node) := Nodes.Table (Old_Node);
+ Nodes.Table (Sav_Node).In_List := False;
+ Nodes.Table (Sav_Node).Link := Union_Id (Empty);
+
+ Orig_Nodes.Increment_Last;
+ Allocate_List_Tables (Nodes.Last);
+
+ Orig_Nodes.Table (Sav_Node) := Sav_Node;
+ Orig_Nodes.Table (Old_Node) := Sav_Node;
+ end if;
+
+ -- Copy substitute node into place, preserving old fields as required
+
+ Nodes.Table (Old_Node) := Nodes.Table (New_Node);
+ Nodes.Table (Old_Node).Link := Old_Link;
+ Nodes.Table (Old_Node).In_List := Old_In_List;
+ Nodes.Table (Old_Node).Error_Posted := Old_Error_P;
+
+ if Nkind (New_Node) in N_Subexpr then
+ Set_Paren_Count (Old_Node, Old_Paren_Count);
+ Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
+ end if;
+
+ Fix_Parent (Field1 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field2 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field3 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field4 (Old_Node), New_Node, Old_Node);
+ Fix_Parent (Field5 (Old_Node), New_Node, Old_Node);
+
+ end Rewrite;
+
+ ------------------
+ -- Set_Analyzed --
+ ------------------
+
+ procedure Set_Analyzed (N : Node_Id; Val : Boolean := True) is
+ begin
+ Nodes.Table (N).Analyzed := Val;
+ end Set_Analyzed;
+
+ ---------------------------
+ -- Set_Comes_From_Source --
+ ---------------------------
+
+ procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Comes_From_Source := Val;
+ end Set_Comes_From_Source;
+
+ -----------------------------------
+ -- Set_Comes_From_Source_Default --
+ -----------------------------------
+
+ procedure Set_Comes_From_Source_Default (Default : Boolean) is
+ begin
+ Default_Node.Comes_From_Source := Default;
+ end Set_Comes_From_Source_Default;
+
+ --------------------
+ -- Set_Convention --
+ --------------------
+
+ procedure Set_Convention (E : Entity_Id; Val : Convention_Id) is
+ begin
+ pragma Assert (Nkind (E) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (E + 2).Field12'Unrestricted_Access)).Convention :=
+ Val;
+ end Set_Convention;
+
+ ---------------
+ -- Set_Ekind --
+ ---------------
+
+ procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind) is
+ begin
+ pragma Assert (Nkind (E) in N_Entity);
+ Nodes.Table (E + 1).Nkind := E_To_N (Val);
+ end Set_Ekind;
+
+ ----------------------
+ -- Set_Error_Posted --
+ ----------------------
+
+ procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True) is
+ begin
+ Nodes.Table (N).Error_Posted := Val;
+ end Set_Error_Posted;
+
+ ---------------------
+ -- Set_Paren_Count --
+ ---------------------
+
+ procedure Set_Paren_Count (N : Node_Id; Val : Paren_Count_Type) is
+ begin
+ pragma Assert (Nkind (N) in N_Subexpr);
+ Nodes.Table (N).Pflag1 := (Val mod 2 /= 0);
+ Nodes.Table (N).Pflag2 := (Val >= 2);
+ end Set_Paren_Count;
+
+ ----------------
+ -- Set_Parent --
+ ----------------
+
+ procedure Set_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (not Nodes.Table (N).In_List);
+ Nodes.Table (N).Link := Union_Id (Val);
+ end Set_Parent;
+
+ --------------
+ -- Set_Sloc --
+ --------------
+
+ procedure Set_Sloc (N : Node_Id; Val : Source_Ptr) is
+ begin
+ Nodes.Table (N).Sloc := Val;
+ end Set_Sloc;
+
+ ----------
+ -- Sloc --
+ ----------
+
+ function Sloc (N : Node_Id) return Source_Ptr is
+ begin
+ return Nodes.Table (N).Sloc;
+ end Sloc;
+
+ -------------------
+ -- Traverse_Func --
+ -------------------
+
+ function Traverse_Func (Node : Node_Id) return Traverse_Result is
+
+ function Traverse_Field (Fld : Union_Id) return Traverse_Result;
+ -- Fld is one of the fields of Node. If the field points to a
+ -- syntactic node or list, then this node or list is traversed,
+ -- and the result is the result of this traversal. Otherwise
+ -- a value of True is returned with no processing.
+
+ --------------------
+ -- Traverse_Field --
+ --------------------
+
+ function Traverse_Field (Fld : Union_Id) return Traverse_Result is
+ begin
+ if Fld = Union_Id (Empty) then
+ return OK;
+
+ -- Descendent is a node
+
+ elsif Fld in Node_Range then
+
+ -- Traverse descendent that is syntactic subtree node
+
+ if Parent (Node_Id (Fld)) = Node then
+ return Traverse_Func (Node_Id (Fld));
+
+ -- Node that is not a syntactic subtree
+
+ else
+ return OK;
+ end if;
+
+ -- Descendent is a list
+
+ elsif Fld in List_Range then
+
+ -- Traverse descendent that is a syntactic subtree list
+
+ if Parent (List_Id (Fld)) = Node then
+
+ declare
+ Elmt : Node_Id := First (List_Id (Fld));
+ begin
+ while Present (Elmt) loop
+ if Traverse_Func (Elmt) = Abandon then
+ return Abandon;
+ else
+ Next (Elmt);
+ end if;
+ end loop;
+
+ return OK;
+ end;
+
+ -- List that is not a syntactic subtree
+
+ else
+ return OK;
+ end if;
+
+ -- Field was not a node or a list
+
+ else
+ return OK;
+ end if;
+ end Traverse_Field;
+
+ -- Start of processing for Traverse_Func
+
+ begin
+ case Process (Node) is
+ when Abandon =>
+ return Abandon;
+
+ when Skip =>
+ return OK;
+
+ when OK =>
+ if Traverse_Field (Union_Id (Field1 (Node))) = Abandon
+ or else
+ Traverse_Field (Union_Id (Field2 (Node))) = Abandon
+ or else
+ Traverse_Field (Union_Id (Field3 (Node))) = Abandon
+ or else
+ Traverse_Field (Union_Id (Field4 (Node))) = Abandon
+ or else
+ Traverse_Field (Union_Id (Field5 (Node))) = Abandon
+ then
+ return Abandon;
+
+ else
+ return OK;
+ end if;
+
+ end case;
+
+ end Traverse_Func;
+
+ -------------------
+ -- Traverse_Proc --
+ -------------------
+
+ procedure Traverse_Proc (Node : Node_Id) is
+ function Traverse is new Traverse_Func (Process);
+ Discard : Traverse_Result;
+
+ begin
+ Discard := Traverse (Node);
+ end Traverse_Proc;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ Tree_Read_Int (Node_Count);
+ Nodes.Tree_Read;
+ Orig_Nodes.Tree_Read;
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ Tree_Write_Int (Node_Count);
+ Nodes.Tree_Write;
+ Orig_Nodes.Tree_Write;
+ end Tree_Write;
+
+ ------------------------------
+ -- Unchecked Access Package --
+ ------------------------------
+
+ package body Unchecked_Access is
+
+ function Field1 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Field1;
+ end Field1;
+
+ function Field2 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Field2;
+ end Field2;
+
+ function Field3 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Field3;
+ end Field3;
+
+ function Field4 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Field4;
+ end Field4;
+
+ function Field5 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Field5;
+ end Field5;
+
+ function Field6 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field6;
+ end Field6;
+
+ function Field7 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field7;
+ end Field7;
+
+ function Field8 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field8;
+ end Field8;
+
+ function Field9 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field9;
+ end Field9;
+
+ function Field10 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field10;
+ end Field10;
+
+ function Field11 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field11;
+ end Field11;
+
+ function Field12 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Field12;
+ end Field12;
+
+ function Field13 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field6;
+ end Field13;
+
+ function Field14 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field7;
+ end Field14;
+
+ function Field15 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field8;
+ end Field15;
+
+ function Field16 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field9;
+ end Field16;
+
+ function Field17 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field10;
+ end Field17;
+
+ function Field18 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Field11;
+ end Field18;
+
+ function Field19 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Field6;
+ end Field19;
+
+ function Field20 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Field7;
+ end Field20;
+
+ function Field21 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Field8;
+ end Field21;
+
+ function Field22 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Field9;
+ end Field22;
+
+ function Field23 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Field10;
+ end Field23;
+
+ function Node1 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Node_Id (Nodes.Table (N).Field1);
+ end Node1;
+
+ function Node2 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Node_Id (Nodes.Table (N).Field2);
+ end Node2;
+
+ function Node3 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Node_Id (Nodes.Table (N).Field3);
+ end Node3;
+
+ function Node4 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Node_Id (Nodes.Table (N).Field4);
+ end Node4;
+
+ function Node5 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Node_Id (Nodes.Table (N).Field5);
+ end Node5;
+
+ function Node6 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field6);
+ end Node6;
+
+ function Node7 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field7);
+ end Node7;
+
+ function Node8 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field8);
+ end Node8;
+
+ function Node9 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field9);
+ end Node9;
+
+ function Node10 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field10);
+ end Node10;
+
+ function Node11 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field11);
+ end Node11;
+
+ function Node12 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 1).Field12);
+ end Node12;
+
+ function Node13 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field6);
+ end Node13;
+
+ function Node14 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field7);
+ end Node14;
+
+ function Node15 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field8);
+ end Node15;
+
+ function Node16 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field9);
+ end Node16;
+
+ function Node17 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field10);
+ end Node17;
+
+ function Node18 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 2).Field11);
+ end Node18;
+
+ function Node19 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 3).Field6);
+ end Node19;
+
+ function Node20 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 3).Field7);
+ end Node20;
+
+ function Node21 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 3).Field8);
+ end Node21;
+
+ function Node22 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 3).Field9);
+ end Node22;
+
+ function Node23 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 3).Field10);
+ end Node23;
+
+ function List1 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return List_Id (Nodes.Table (N).Field1);
+ end List1;
+
+ function List2 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return List_Id (Nodes.Table (N).Field2);
+ end List2;
+
+ function List3 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return List_Id (Nodes.Table (N).Field3);
+ end List3;
+
+ function List4 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return List_Id (Nodes.Table (N).Field4);
+ end List4;
+
+ function List5 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return List_Id (Nodes.Table (N).Field5);
+ end List5;
+
+ function List10 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return List_Id (Nodes.Table (N + 1).Field10);
+ end List10;
+
+ function List14 (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return List_Id (Nodes.Table (N + 2).Field7);
+ end List14;
+
+ function Elist2 (N : Node_Id) return Elist_Id is
+ begin
+ return Elist_Id (Nodes.Table (N).Field2);
+ end Elist2;
+
+ function Elist3 (N : Node_Id) return Elist_Id is
+ begin
+ return Elist_Id (Nodes.Table (N).Field3);
+ end Elist3;
+
+ function Elist4 (N : Node_Id) return Elist_Id is
+ begin
+ return Elist_Id (Nodes.Table (N).Field4);
+ end Elist4;
+
+ function Elist8 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 1).Field8);
+ end Elist8;
+
+ function Elist13 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 2).Field6);
+ end Elist13;
+
+ function Elist15 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 2).Field8);
+ end Elist15;
+
+ function Elist16 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 2).Field9);
+ end Elist16;
+
+ function Elist18 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 2).Field11);
+ end Elist18;
+
+ function Elist21 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 3).Field8);
+ end Elist21;
+
+ function Elist23 (N : Node_Id) return Elist_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Elist_Id (Nodes.Table (N + 3).Field10);
+ end Elist23;
+
+ function Name1 (N : Node_Id) return Name_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Name_Id (Nodes.Table (N).Field1);
+ end Name1;
+
+ function Name2 (N : Node_Id) return Name_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Name_Id (Nodes.Table (N).Field2);
+ end Name2;
+
+ function Str3 (N : Node_Id) return String_Id is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return String_Id (Nodes.Table (N).Field3);
+ end Str3;
+
+ function Char_Code2 (N : Node_Id) return Char_Code is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Char_Code (Nodes.Table (N).Field2 - Char_Code_Bias);
+ end Char_Code2;
+
+ function Uint3 (N : Node_Id) return Uint is
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ U : constant Union_Id := Nodes.Table (N).Field3;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint3;
+
+ function Uint4 (N : Node_Id) return Uint is
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ U : constant Union_Id := Nodes.Table (N).Field4;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint4;
+
+ function Uint5 (N : Node_Id) return Uint is
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ U : constant Union_Id := Nodes.Table (N).Field5;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint5;
+
+ function Uint8 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 1).Field8;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint8;
+
+ function Uint9 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 1).Field9;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint9;
+
+ function Uint11 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 1).Field11;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint11;
+
+ function Uint10 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 1).Field10;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint10;
+
+ function Uint12 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 1).Field12;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint12;
+
+ function Uint13 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 2).Field6;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint13;
+
+ function Uint14 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 2).Field7;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint14;
+
+ function Uint15 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 2).Field8;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint15;
+
+ function Uint16 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 2).Field9;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint16;
+
+ function Uint17 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 2).Field10;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint17;
+
+ function Uint22 (N : Node_Id) return Uint is
+ pragma Assert (Nkind (N) in N_Entity);
+ U : constant Union_Id := Nodes.Table (N + 3).Field9;
+
+ begin
+ if U = 0 then
+ return Uint_0;
+ else
+ return From_Union (U);
+ end if;
+ end Uint22;
+
+ function Ureal3 (N : Node_Id) return Ureal is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return From_Union (Nodes.Table (N).Field3);
+ end Ureal3;
+
+ function Ureal18 (N : Node_Id) return Ureal is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return From_Union (Nodes.Table (N + 2).Field11);
+ end Ureal18;
+
+ function Ureal21 (N : Node_Id) return Ureal is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return From_Union (Nodes.Table (N + 3).Field8);
+ end Ureal21;
+
+ function Flag4 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag4;
+ end Flag4;
+
+ function Flag5 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag5;
+ end Flag5;
+
+ function Flag6 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag6;
+ end Flag6;
+
+ function Flag7 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag7;
+ end Flag7;
+
+ function Flag8 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag8;
+ end Flag8;
+
+ function Flag9 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag9;
+ end Flag9;
+
+ function Flag10 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag10;
+ end Flag10;
+
+ function Flag11 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag11;
+ end Flag11;
+
+ function Flag12 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag12;
+ end Flag12;
+
+ function Flag13 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag13;
+ end Flag13;
+
+ function Flag14 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag14;
+ end Flag14;
+
+ function Flag15 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag15;
+ end Flag15;
+
+ function Flag16 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag16;
+ end Flag16;
+
+ function Flag17 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag17;
+ end Flag17;
+
+ function Flag18 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ return Nodes.Table (N).Flag18;
+ end Flag18;
+
+ function Flag19 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).In_List;
+ end Flag19;
+
+ function Flag20 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Unused_1;
+ end Flag20;
+
+ function Flag21 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Rewrite_Ins;
+ end Flag21;
+
+ function Flag22 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Analyzed;
+ end Flag22;
+
+ function Flag23 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Comes_From_Source;
+ end Flag23;
+
+ function Flag24 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Error_Posted;
+ end Flag24;
+
+ function Flag25 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag4;
+ end Flag25;
+
+ function Flag26 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag5;
+ end Flag26;
+
+ function Flag27 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag6;
+ end Flag27;
+
+ function Flag28 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag7;
+ end Flag28;
+
+ function Flag29 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag8;
+ end Flag29;
+
+ function Flag30 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag9;
+ end Flag30;
+
+ function Flag31 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag10;
+ end Flag31;
+
+ function Flag32 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag11;
+ end Flag32;
+
+ function Flag33 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag12;
+ end Flag33;
+
+ function Flag34 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag13;
+ end Flag34;
+
+ function Flag35 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag14;
+ end Flag35;
+
+ function Flag36 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag15;
+ end Flag36;
+
+ function Flag37 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag16;
+ end Flag37;
+
+ function Flag38 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag17;
+ end Flag38;
+
+ function Flag39 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Flag18;
+ end Flag39;
+
+ function Flag40 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).In_List;
+ end Flag40;
+
+ function Flag41 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Unused_1;
+ end Flag41;
+
+ function Flag42 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Rewrite_Ins;
+ end Flag42;
+
+ function Flag43 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Analyzed;
+ end Flag43;
+
+ function Flag44 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Comes_From_Source;
+ end Flag44;
+
+ function Flag45 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Error_Posted;
+ end Flag45;
+
+ function Flag46 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag4;
+ end Flag46;
+
+ function Flag47 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag5;
+ end Flag47;
+
+ function Flag48 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag6;
+ end Flag48;
+
+ function Flag49 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag7;
+ end Flag49;
+
+ function Flag50 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag8;
+ end Flag50;
+
+ function Flag51 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag9;
+ end Flag51;
+
+ function Flag52 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag10;
+ end Flag52;
+
+ function Flag53 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag11;
+ end Flag53;
+
+ function Flag54 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag12;
+ end Flag54;
+
+ function Flag55 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag13;
+ end Flag55;
+
+ function Flag56 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag14;
+ end Flag56;
+
+ function Flag57 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag15;
+ end Flag57;
+
+ function Flag58 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag16;
+ end Flag58;
+
+ function Flag59 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag17;
+ end Flag59;
+
+ function Flag60 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Flag18;
+ end Flag60;
+
+ function Flag61 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Pflag1;
+ end Flag61;
+
+ function Flag62 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 1).Pflag2;
+ end Flag62;
+
+ function Flag63 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Pflag1;
+ end Flag63;
+
+ function Flag64 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 2).Pflag2;
+ end Flag64;
+
+ function Flag65 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag65;
+ end Flag65;
+
+ function Flag66 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag66;
+ end Flag66;
+
+ function Flag67 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag67;
+ end Flag67;
+
+ function Flag68 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag68;
+ end Flag68;
+
+ function Flag69 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag69;
+ end Flag69;
+
+ function Flag70 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag70;
+ end Flag70;
+
+ function Flag71 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag71;
+ end Flag71;
+
+ function Flag72 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag72;
+ end Flag72;
+
+ function Flag73 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag73;
+ end Flag73;
+
+ function Flag74 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag74;
+ end Flag74;
+
+ function Flag75 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag75;
+ end Flag75;
+
+ function Flag76 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag76;
+ end Flag76;
+
+ function Flag77 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag77;
+ end Flag77;
+
+ function Flag78 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag78;
+ end Flag78;
+
+ function Flag79 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag79;
+ end Flag79;
+
+ function Flag80 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag80;
+ end Flag80;
+
+ function Flag81 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag81;
+ end Flag81;
+
+ function Flag82 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag82;
+ end Flag82;
+
+ function Flag83 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag83;
+ end Flag83;
+
+ function Flag84 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag84;
+ end Flag84;
+
+ function Flag85 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag85;
+ end Flag85;
+
+ function Flag86 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag86;
+ end Flag86;
+
+ function Flag87 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag87;
+ end Flag87;
+
+ function Flag88 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag88;
+ end Flag88;
+
+ function Flag89 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag89;
+ end Flag89;
+
+ function Flag90 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag90;
+ end Flag90;
+
+ function Flag91 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag91;
+ end Flag91;
+
+ function Flag92 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag92;
+ end Flag92;
+
+ function Flag93 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag93;
+ end Flag93;
+
+ function Flag94 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag94;
+ end Flag94;
+
+ function Flag95 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag95;
+ end Flag95;
+
+ function Flag96 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag96;
+ end Flag96;
+
+ function Flag97 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag97;
+ end Flag97;
+
+ function Flag98 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag98;
+ end Flag98;
+
+ function Flag99 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag99;
+ end Flag99;
+
+ function Flag100 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag100;
+ end Flag100;
+
+ function Flag101 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag101;
+ end Flag101;
+
+ function Flag102 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag102;
+ end Flag102;
+
+ function Flag103 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag103;
+ end Flag103;
+
+ function Flag104 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag104;
+ end Flag104;
+
+ function Flag105 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag105;
+ end Flag105;
+
+ function Flag106 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag106;
+ end Flag106;
+
+ function Flag107 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag107;
+ end Flag107;
+
+ function Flag108 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag108;
+ end Flag108;
+
+ function Flag109 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag109;
+ end Flag109;
+
+ function Flag110 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag110;
+ end Flag110;
+
+ function Flag111 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag111;
+ end Flag111;
+
+ function Flag112 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag112;
+ end Flag112;
+
+ function Flag113 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag113;
+ end Flag113;
+
+ function Flag114 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag114;
+ end Flag114;
+
+ function Flag115 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag115;
+ end Flag115;
+
+ function Flag116 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag116;
+ end Flag116;
+
+ function Flag117 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag117;
+ end Flag117;
+
+ function Flag118 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag118;
+ end Flag118;
+
+ function Flag119 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag119;
+ end Flag119;
+
+ function Flag120 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag120;
+ end Flag120;
+
+ function Flag121 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag121;
+ end Flag121;
+
+ function Flag122 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag122;
+ end Flag122;
+
+ function Flag123 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag123;
+ end Flag123;
+
+ function Flag124 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag124;
+ end Flag124;
+
+ function Flag125 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag125;
+ end Flag125;
+
+ function Flag126 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag126;
+ end Flag126;
+
+ function Flag127 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag127;
+ end Flag127;
+
+ function Flag128 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag128;
+ end Flag128;
+
+ function Flag129 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).In_List;
+ end Flag129;
+
+ function Flag130 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Unused_1;
+ end Flag130;
+
+ function Flag131 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Rewrite_Ins;
+ end Flag131;
+
+ function Flag132 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Analyzed;
+ end Flag132;
+
+ function Flag133 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Comes_From_Source;
+ end Flag133;
+
+ function Flag134 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Error_Posted;
+ end Flag134;
+
+ function Flag135 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag4;
+ end Flag135;
+
+ function Flag136 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag5;
+ end Flag136;
+
+ function Flag137 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag6;
+ end Flag137;
+
+ function Flag138 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag7;
+ end Flag138;
+
+ function Flag139 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag8;
+ end Flag139;
+
+ function Flag140 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag9;
+ end Flag140;
+
+ function Flag141 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag10;
+ end Flag141;
+
+ function Flag142 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag11;
+ end Flag142;
+
+ function Flag143 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag12;
+ end Flag143;
+
+ function Flag144 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag13;
+ end Flag144;
+
+ function Flag145 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag14;
+ end Flag145;
+
+ function Flag146 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag15;
+ end Flag146;
+
+ function Flag147 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag16;
+ end Flag147;
+
+ function Flag148 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag17;
+ end Flag148;
+
+ function Flag149 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Flag18;
+ end Flag149;
+
+ function Flag150 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Pflag1;
+ end Flag150;
+
+ function Flag151 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 3).Pflag2;
+ end Flag151;
+
+ function Flag152 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag152;
+ end Flag152;
+
+ function Flag153 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag153;
+ end Flag153;
+
+ function Flag154 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag154;
+ end Flag154;
+
+ function Flag155 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag155;
+ end Flag155;
+
+ function Flag156 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag156;
+ end Flag156;
+
+ function Flag157 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag157;
+ end Flag157;
+
+ function Flag158 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag158;
+ end Flag158;
+
+ function Flag159 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag159;
+ end Flag159;
+
+ function Flag160 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag160;
+ end Flag160;
+
+ function Flag161 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag161;
+ end Flag161;
+
+ function Flag162 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag162;
+ end Flag162;
+
+ function Flag163 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag163;
+ end Flag163;
+
+ function Flag164 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag164;
+ end Flag164;
+
+ function Flag165 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag165;
+ end Flag165;
+
+ function Flag166 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag166;
+ end Flag166;
+
+ function Flag167 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag167;
+ end Flag167;
+
+ function Flag168 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag168;
+ end Flag168;
+
+ function Flag169 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag169;
+ end Flag169;
+
+ function Flag170 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag170;
+ end Flag170;
+
+ function Flag171 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag171;
+ end Flag171;
+
+ function Flag172 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag172;
+ end Flag172;
+
+ function Flag173 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag173;
+ end Flag173;
+
+ function Flag174 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag174;
+ end Flag174;
+
+ function Flag175 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag175;
+ end Flag175;
+
+ function Flag176 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag176;
+ end Flag176;
+
+ function Flag177 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag177;
+ end Flag177;
+
+ function Flag178 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag178;
+ end Flag178;
+
+ function Flag179 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag179;
+ end Flag179;
+
+ function Flag180 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag180;
+ end Flag180;
+
+ function Flag181 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag181;
+ end Flag181;
+
+ function Flag182 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag182;
+ end Flag182;
+
+ function Flag183 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag183;
+ end Flag183;
+
+ procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Nkind := Val;
+ end Set_Nkind;
+
+ procedure Set_Field1 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field1 := Val;
+ end Set_Field1;
+
+ procedure Set_Field2 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field2 := Val;
+ end Set_Field2;
+
+ procedure Set_Field3 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := Val;
+ end Set_Field3;
+
+ procedure Set_Field4 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field4 := Val;
+ end Set_Field4;
+
+ procedure Set_Field5 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field5 := Val;
+ end Set_Field5;
+
+ procedure Set_Field6 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field6 := Val;
+ end Set_Field6;
+
+ procedure Set_Field7 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field7 := Val;
+ end Set_Field7;
+
+ procedure Set_Field8 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field8 := Val;
+ end Set_Field8;
+
+ procedure Set_Field9 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field9 := Val;
+ end Set_Field9;
+
+ procedure Set_Field10 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field10 := Val;
+ end Set_Field10;
+
+ procedure Set_Field11 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field11 := Val;
+ end Set_Field11;
+
+ procedure Set_Field12 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field12 := Val;
+ end Set_Field12;
+
+ procedure Set_Field13 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field6 := Val;
+ end Set_Field13;
+
+ procedure Set_Field14 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field7 := Val;
+ end Set_Field14;
+
+ procedure Set_Field15 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field8 := Val;
+ end Set_Field15;
+
+ procedure Set_Field16 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field9 := Val;
+ end Set_Field16;
+
+ procedure Set_Field17 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field10 := Val;
+ end Set_Field17;
+
+ procedure Set_Field18 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field11 := Val;
+ end Set_Field18;
+
+ procedure Set_Field19 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field6 := Val;
+ end Set_Field19;
+
+ procedure Set_Field20 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field7 := Val;
+ end Set_Field20;
+
+ procedure Set_Field21 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field8 := Val;
+ end Set_Field21;
+
+ procedure Set_Field22 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field9 := Val;
+ end Set_Field22;
+
+ procedure Set_Field23 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field10 := Val;
+ end Set_Field23;
+
+ procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field1 := Union_Id (Val);
+ end Set_Node1;
+
+ procedure Set_Node2 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field2 := Union_Id (Val);
+ end Set_Node2;
+
+ procedure Set_Node3 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := Union_Id (Val);
+ end Set_Node3;
+
+ procedure Set_Node4 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field4 := Union_Id (Val);
+ end Set_Node4;
+
+ procedure Set_Node5 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field5 := Union_Id (Val);
+ end Set_Node5;
+
+ procedure Set_Node6 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field6 := Union_Id (Val);
+ end Set_Node6;
+
+ procedure Set_Node7 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field7 := Union_Id (Val);
+ end Set_Node7;
+
+ procedure Set_Node8 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field8 := Union_Id (Val);
+ end Set_Node8;
+
+ procedure Set_Node9 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field9 := Union_Id (Val);
+ end Set_Node9;
+
+ procedure Set_Node10 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field10 := Union_Id (Val);
+ end Set_Node10;
+
+ procedure Set_Node11 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field11 := Union_Id (Val);
+ end Set_Node11;
+
+ procedure Set_Node12 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field12 := Union_Id (Val);
+ end Set_Node12;
+
+ procedure Set_Node13 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field6 := Union_Id (Val);
+ end Set_Node13;
+
+ procedure Set_Node14 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field7 := Union_Id (Val);
+ end Set_Node14;
+
+ procedure Set_Node15 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field8 := Union_Id (Val);
+ end Set_Node15;
+
+ procedure Set_Node16 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field9 := Union_Id (Val);
+ end Set_Node16;
+
+ procedure Set_Node17 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field10 := Union_Id (Val);
+ end Set_Node17;
+
+ procedure Set_Node18 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field11 := Union_Id (Val);
+ end Set_Node18;
+
+ procedure Set_Node19 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field6 := Union_Id (Val);
+ end Set_Node19;
+
+ procedure Set_Node20 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field7 := Union_Id (Val);
+ end Set_Node20;
+
+ procedure Set_Node21 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field8 := Union_Id (Val);
+ end Set_Node21;
+
+ procedure Set_Node22 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field9 := Union_Id (Val);
+ end Set_Node22;
+
+ procedure Set_Node23 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field10 := Union_Id (Val);
+ end Set_Node23;
+
+ procedure Set_List1 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field1 := Union_Id (Val);
+ end Set_List1;
+
+ procedure Set_List2 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field2 := Union_Id (Val);
+ end Set_List2;
+
+ procedure Set_List3 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := Union_Id (Val);
+ end Set_List3;
+
+ procedure Set_List4 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field4 := Union_Id (Val);
+ end Set_List4;
+
+ procedure Set_List5 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field5 := Union_Id (Val);
+ end Set_List5;
+
+ procedure Set_List10 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field10 := Union_Id (Val);
+ end Set_List10;
+
+ procedure Set_List14 (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field7 := Union_Id (Val);
+ end Set_List14;
+
+ procedure Set_Elist2 (N : Node_Id; Val : Elist_Id) is
+ begin
+ Nodes.Table (N).Field2 := Union_Id (Val);
+ end Set_Elist2;
+
+ procedure Set_Elist3 (N : Node_Id; Val : Elist_Id) is
+ begin
+ Nodes.Table (N).Field3 := Union_Id (Val);
+ end Set_Elist3;
+
+ procedure Set_Elist4 (N : Node_Id; Val : Elist_Id) is
+ begin
+ Nodes.Table (N).Field4 := Union_Id (Val);
+ end Set_Elist4;
+
+ procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field8 := Union_Id (Val);
+ end Set_Elist8;
+
+ procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field6 := Union_Id (Val);
+ end Set_Elist13;
+
+ procedure Set_Elist15 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field8 := Union_Id (Val);
+ end Set_Elist15;
+
+ procedure Set_Elist16 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field9 := Union_Id (Val);
+ end Set_Elist16;
+
+ procedure Set_Elist18 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field11 := Union_Id (Val);
+ end Set_Elist18;
+
+ procedure Set_Elist21 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field8 := Union_Id (Val);
+ end Set_Elist21;
+
+ procedure Set_Elist23 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field10 := Union_Id (Val);
+ end Set_Elist23;
+
+ procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field1 := Union_Id (Val);
+ end Set_Name1;
+
+ procedure Set_Name2 (N : Node_Id; Val : Name_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field2 := Union_Id (Val);
+ end Set_Name2;
+
+ procedure Set_Str3 (N : Node_Id; Val : String_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := Union_Id (Val);
+ end Set_Str3;
+
+ procedure Set_Uint3 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := To_Union (Val);
+ end Set_Uint3;
+
+ procedure Set_Uint4 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field4 := To_Union (Val);
+ end Set_Uint4;
+
+ procedure Set_Uint5 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field5 := To_Union (Val);
+ end Set_Uint5;
+
+ procedure Set_Uint8 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field8 := To_Union (Val);
+ end Set_Uint8;
+
+ procedure Set_Uint9 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field9 := To_Union (Val);
+ end Set_Uint9;
+
+ procedure Set_Uint10 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field10 := To_Union (Val);
+ end Set_Uint10;
+
+ procedure Set_Uint11 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field11 := To_Union (Val);
+ end Set_Uint11;
+
+ procedure Set_Uint12 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Field12 := To_Union (Val);
+ end Set_Uint12;
+
+ procedure Set_Uint13 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field6 := To_Union (Val);
+ end Set_Uint13;
+
+ procedure Set_Uint14 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field7 := To_Union (Val);
+ end Set_Uint14;
+
+ procedure Set_Uint15 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field8 := To_Union (Val);
+ end Set_Uint15;
+
+ procedure Set_Uint16 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field9 := To_Union (Val);
+ end Set_Uint16;
+
+ procedure Set_Uint17 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field10 := To_Union (Val);
+ end Set_Uint17;
+
+ procedure Set_Uint22 (N : Node_Id; Val : Uint) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field9 := To_Union (Val);
+ end Set_Uint22;
+
+ procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field3 := To_Union (Val);
+ end Set_Ureal3;
+
+ procedure Set_Ureal18 (N : Node_Id; Val : Ureal) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Field11 := To_Union (Val);
+ end Set_Ureal18;
+
+ procedure Set_Ureal21 (N : Node_Id; Val : Ureal) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Field8 := To_Union (Val);
+ end Set_Ureal21;
+
+ procedure Set_Char_Code2 (N : Node_Id; Val : Char_Code) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Field2 := Union_Id (Val) + Char_Code_Bias;
+ end Set_Char_Code2;
+
+ procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag4 := Val;
+ end Set_Flag4;
+
+ procedure Set_Flag5 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag5 := Val;
+ end Set_Flag5;
+
+ procedure Set_Flag6 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag6 := Val;
+ end Set_Flag6;
+
+ procedure Set_Flag7 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag7 := Val;
+ end Set_Flag7;
+
+ procedure Set_Flag8 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag8 := Val;
+ end Set_Flag8;
+
+ procedure Set_Flag9 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag9 := Val;
+ end Set_Flag9;
+
+ procedure Set_Flag10 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag10 := Val;
+ end Set_Flag10;
+
+ procedure Set_Flag11 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag11 := Val;
+ end Set_Flag11;
+
+ procedure Set_Flag12 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag12 := Val;
+ end Set_Flag12;
+
+ procedure Set_Flag13 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag13 := Val;
+ end Set_Flag13;
+
+ procedure Set_Flag14 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag14 := Val;
+ end Set_Flag14;
+
+ procedure Set_Flag15 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag15 := Val;
+ end Set_Flag15;
+
+ procedure Set_Flag16 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag16 := Val;
+ end Set_Flag16;
+
+ procedure Set_Flag17 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag17 := Val;
+ end Set_Flag17;
+
+ procedure Set_Flag18 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ Nodes.Table (N).Flag18 := Val;
+ end Set_Flag18;
+
+ procedure Set_Flag19 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).In_List := Val;
+ end Set_Flag19;
+
+ procedure Set_Flag20 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Unused_1 := Val;
+ end Set_Flag20;
+
+ procedure Set_Flag21 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Rewrite_Ins := Val;
+ end Set_Flag21;
+
+ procedure Set_Flag22 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Analyzed := Val;
+ end Set_Flag22;
+
+ procedure Set_Flag23 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Comes_From_Source := Val;
+ end Set_Flag23;
+
+ procedure Set_Flag24 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Error_Posted := Val;
+ end Set_Flag24;
+
+ procedure Set_Flag25 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag4 := Val;
+ end Set_Flag25;
+
+ procedure Set_Flag26 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag5 := Val;
+ end Set_Flag26;
+
+ procedure Set_Flag27 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag6 := Val;
+ end Set_Flag27;
+
+ procedure Set_Flag28 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag7 := Val;
+ end Set_Flag28;
+
+ procedure Set_Flag29 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag8 := Val;
+ end Set_Flag29;
+
+ procedure Set_Flag30 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag9 := Val;
+ end Set_Flag30;
+
+ procedure Set_Flag31 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag10 := Val;
+ end Set_Flag31;
+
+ procedure Set_Flag32 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag11 := Val;
+ end Set_Flag32;
+
+ procedure Set_Flag33 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag12 := Val;
+ end Set_Flag33;
+
+ procedure Set_Flag34 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag13 := Val;
+ end Set_Flag34;
+
+ procedure Set_Flag35 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag14 := Val;
+ end Set_Flag35;
+
+ procedure Set_Flag36 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag15 := Val;
+ end Set_Flag36;
+
+ procedure Set_Flag37 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag16 := Val;
+ end Set_Flag37;
+
+ procedure Set_Flag38 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag17 := Val;
+ end Set_Flag38;
+
+ procedure Set_Flag39 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Flag18 := Val;
+ end Set_Flag39;
+
+ procedure Set_Flag40 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).In_List := Val;
+ end Set_Flag40;
+
+ procedure Set_Flag41 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Unused_1 := Val;
+ end Set_Flag41;
+
+ procedure Set_Flag42 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Rewrite_Ins := Val;
+ end Set_Flag42;
+
+ procedure Set_Flag43 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Analyzed := Val;
+ end Set_Flag43;
+
+ procedure Set_Flag44 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Comes_From_Source := Val;
+ end Set_Flag44;
+
+ procedure Set_Flag45 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Error_Posted := Val;
+ end Set_Flag45;
+
+ procedure Set_Flag46 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag4 := Val;
+ end Set_Flag46;
+
+ procedure Set_Flag47 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag5 := Val;
+ end Set_Flag47;
+
+ procedure Set_Flag48 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag6 := Val;
+ end Set_Flag48;
+
+ procedure Set_Flag49 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag7 := Val;
+ end Set_Flag49;
+
+ procedure Set_Flag50 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag8 := Val;
+ end Set_Flag50;
+
+ procedure Set_Flag51 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag9 := Val;
+ end Set_Flag51;
+
+ procedure Set_Flag52 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag10 := Val;
+ end Set_Flag52;
+
+ procedure Set_Flag53 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag11 := Val;
+ end Set_Flag53;
+
+ procedure Set_Flag54 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag12 := Val;
+ end Set_Flag54;
+
+ procedure Set_Flag55 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag13 := Val;
+ end Set_Flag55;
+
+ procedure Set_Flag56 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag14 := Val;
+ end Set_Flag56;
+
+ procedure Set_Flag57 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag15 := Val;
+ end Set_Flag57;
+
+ procedure Set_Flag58 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag16 := Val;
+ end Set_Flag58;
+
+ procedure Set_Flag59 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag17 := Val;
+ end Set_Flag59;
+
+ procedure Set_Flag60 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Flag18 := Val;
+ end Set_Flag60;
+
+ procedure Set_Flag61 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Pflag1 := Val;
+ end Set_Flag61;
+
+ procedure Set_Flag62 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 1).Pflag2 := Val;
+ end Set_Flag62;
+
+ procedure Set_Flag63 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Pflag1 := Val;
+ end Set_Flag63;
+
+ procedure Set_Flag64 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 2).Pflag2 := Val;
+ end Set_Flag64;
+
+ procedure Set_Flag65 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag65 := Val;
+ end Set_Flag65;
+
+ procedure Set_Flag66 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag66 := Val;
+ end Set_Flag66;
+
+ procedure Set_Flag67 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag67 := Val;
+ end Set_Flag67;
+
+ procedure Set_Flag68 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag68 := Val;
+ end Set_Flag68;
+
+ procedure Set_Flag69 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag69 := Val;
+ end Set_Flag69;
+
+ procedure Set_Flag70 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag70 := Val;
+ end Set_Flag70;
+
+ procedure Set_Flag71 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag71 := Val;
+ end Set_Flag71;
+
+ procedure Set_Flag72 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Byte_Ptr
+ (Node_Kind_Ptr'
+ (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag72 := Val;
+ end Set_Flag72;
+
+ procedure Set_Flag73 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag73 := Val;
+ end Set_Flag73;
+
+ procedure Set_Flag74 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag74 := Val;
+ end Set_Flag74;
+
+ procedure Set_Flag75 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag75 := Val;
+ end Set_Flag75;
+
+ procedure Set_Flag76 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag76 := Val;
+ end Set_Flag76;
+
+ procedure Set_Flag77 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag77 := Val;
+ end Set_Flag77;
+
+ procedure Set_Flag78 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag78 := Val;
+ end Set_Flag78;
+
+ procedure Set_Flag79 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag79 := Val;
+ end Set_Flag79;
+
+ procedure Set_Flag80 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag80 := Val;
+ end Set_Flag80;
+
+ procedure Set_Flag81 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag81 := Val;
+ end Set_Flag81;
+
+ procedure Set_Flag82 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag82 := Val;
+ end Set_Flag82;
+
+ procedure Set_Flag83 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag83 := Val;
+ end Set_Flag83;
+
+ procedure Set_Flag84 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag84 := Val;
+ end Set_Flag84;
+
+ procedure Set_Flag85 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag85 := Val;
+ end Set_Flag85;
+
+ procedure Set_Flag86 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag86 := Val;
+ end Set_Flag86;
+
+ procedure Set_Flag87 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag87 := Val;
+ end Set_Flag87;
+
+ procedure Set_Flag88 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag88 := Val;
+ end Set_Flag88;
+
+ procedure Set_Flag89 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag89 := Val;
+ end Set_Flag89;
+
+ procedure Set_Flag90 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag90 := Val;
+ end Set_Flag90;
+
+ procedure Set_Flag91 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag91 := Val;
+ end Set_Flag91;
+
+ procedure Set_Flag92 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag92 := Val;
+ end Set_Flag92;
+
+ procedure Set_Flag93 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag93 := Val;
+ end Set_Flag93;
+
+ procedure Set_Flag94 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag94 := Val;
+ end Set_Flag94;
+
+ procedure Set_Flag95 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag95 := Val;
+ end Set_Flag95;
+
+ procedure Set_Flag96 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag96 := Val;
+ end Set_Flag96;
+
+ procedure Set_Flag97 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag97 := Val;
+ end Set_Flag97;
+
+ procedure Set_Flag98 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag98 := Val;
+ end Set_Flag98;
+
+ procedure Set_Flag99 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag99 := Val;
+ end Set_Flag99;
+
+ procedure Set_Flag100 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag100 := Val;
+ end Set_Flag100;
+
+ procedure Set_Flag101 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag101 := Val;
+ end Set_Flag101;
+
+ procedure Set_Flag102 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag102 := Val;
+ end Set_Flag102;
+
+ procedure Set_Flag103 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag103 := Val;
+ end Set_Flag103;
+
+ procedure Set_Flag104 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag104 := Val;
+ end Set_Flag104;
+
+ procedure Set_Flag105 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag105 := Val;
+ end Set_Flag105;
+
+ procedure Set_Flag106 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag106 := Val;
+ end Set_Flag106;
+
+ procedure Set_Flag107 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag107 := Val;
+ end Set_Flag107;
+
+ procedure Set_Flag108 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag108 := Val;
+ end Set_Flag108;
+
+ procedure Set_Flag109 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag109 := Val;
+ end Set_Flag109;
+
+ procedure Set_Flag110 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag110 := Val;
+ end Set_Flag110;
+
+ procedure Set_Flag111 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag111 := Val;
+ end Set_Flag111;
+
+ procedure Set_Flag112 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag112 := Val;
+ end Set_Flag112;
+
+ procedure Set_Flag113 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag113 := Val;
+ end Set_Flag113;
+
+ procedure Set_Flag114 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag114 := Val;
+ end Set_Flag114;
+
+ procedure Set_Flag115 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag115 := Val;
+ end Set_Flag115;
+
+ procedure Set_Flag116 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag116 := Val;
+ end Set_Flag116;
+
+ procedure Set_Flag117 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag117 := Val;
+ end Set_Flag117;
+
+ procedure Set_Flag118 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag118 := Val;
+ end Set_Flag118;
+
+ procedure Set_Flag119 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag119 := Val;
+ end Set_Flag119;
+
+ procedure Set_Flag120 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag120 := Val;
+ end Set_Flag120;
+
+ procedure Set_Flag121 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag121 := Val;
+ end Set_Flag121;
+
+ procedure Set_Flag122 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag122 := Val;
+ end Set_Flag122;
+
+ procedure Set_Flag123 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag123 := Val;
+ end Set_Flag123;
+
+ procedure Set_Flag124 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag124 := Val;
+ end Set_Flag124;
+
+ procedure Set_Flag125 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag125 := Val;
+ end Set_Flag125;
+
+ procedure Set_Flag126 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag126 := Val;
+ end Set_Flag126;
+
+ procedure Set_Flag127 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag127 := Val;
+ end Set_Flag127;
+
+ procedure Set_Flag128 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word2_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag128 := Val;
+ end Set_Flag128;
+
+ procedure Set_Flag129 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).In_List := Val;
+ end Set_Flag129;
+
+ procedure Set_Flag130 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Unused_1 := Val;
+ end Set_Flag130;
+
+ procedure Set_Flag131 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Rewrite_Ins := Val;
+ end Set_Flag131;
+
+ procedure Set_Flag132 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Analyzed := Val;
+ end Set_Flag132;
+
+ procedure Set_Flag133 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Comes_From_Source := Val;
+ end Set_Flag133;
+
+ procedure Set_Flag134 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Error_Posted := Val;
+ end Set_Flag134;
+
+ procedure Set_Flag135 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag4 := Val;
+ end Set_Flag135;
+
+ procedure Set_Flag136 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag5 := Val;
+ end Set_Flag136;
+
+ procedure Set_Flag137 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag6 := Val;
+ end Set_Flag137;
+
+ procedure Set_Flag138 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag7 := Val;
+ end Set_Flag138;
+
+ procedure Set_Flag139 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag8 := Val;
+ end Set_Flag139;
+
+ procedure Set_Flag140 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag9 := Val;
+ end Set_Flag140;
+
+ procedure Set_Flag141 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag10 := Val;
+ end Set_Flag141;
+
+ procedure Set_Flag142 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag11 := Val;
+ end Set_Flag142;
+
+ procedure Set_Flag143 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag12 := Val;
+ end Set_Flag143;
+
+ procedure Set_Flag144 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag13 := Val;
+ end Set_Flag144;
+
+ procedure Set_Flag145 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag14 := Val;
+ end Set_Flag145;
+
+ procedure Set_Flag146 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag15 := Val;
+ end Set_Flag146;
+
+ procedure Set_Flag147 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag16 := Val;
+ end Set_Flag147;
+
+ procedure Set_Flag148 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag17 := Val;
+ end Set_Flag148;
+
+ procedure Set_Flag149 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Flag18 := Val;
+ end Set_Flag149;
+
+ procedure Set_Flag150 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Pflag1 := Val;
+ end Set_Flag150;
+
+ procedure Set_Flag151 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 3).Pflag2 := Val;
+ end Set_Flag151;
+
+ procedure Set_Flag152 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag152 := Val;
+ end Set_Flag152;
+
+ procedure Set_Flag153 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag153 := Val;
+ end Set_Flag153;
+
+ procedure Set_Flag154 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag154 := Val;
+ end Set_Flag154;
+
+ procedure Set_Flag155 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag155 := Val;
+ end Set_Flag155;
+
+ procedure Set_Flag156 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag156 := Val;
+ end Set_Flag156;
+
+ procedure Set_Flag157 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag157 := Val;
+ end Set_Flag157;
+
+ procedure Set_Flag158 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag158 := Val;
+ end Set_Flag158;
+
+ procedure Set_Flag159 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag159 := Val;
+ end Set_Flag159;
+
+ procedure Set_Flag160 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag160 := Val;
+ end Set_Flag160;
+
+ procedure Set_Flag161 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag161 := Val;
+ end Set_Flag161;
+
+ procedure Set_Flag162 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag162 := Val;
+ end Set_Flag162;
+
+ procedure Set_Flag163 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag163 := Val;
+ end Set_Flag163;
+
+ procedure Set_Flag164 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag164 := Val;
+ end Set_Flag164;
+
+ procedure Set_Flag165 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag165 := Val;
+ end Set_Flag165;
+
+ procedure Set_Flag166 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag166 := Val;
+ end Set_Flag166;
+
+ procedure Set_Flag167 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag167 := Val;
+ end Set_Flag167;
+
+ procedure Set_Flag168 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag168 := Val;
+ end Set_Flag168;
+
+ procedure Set_Flag169 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag169 := Val;
+ end Set_Flag169;
+
+ procedure Set_Flag170 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag170 := Val;
+ end Set_Flag170;
+
+ procedure Set_Flag171 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag171 := Val;
+ end Set_Flag171;
+
+ procedure Set_Flag172 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag172 := Val;
+ end Set_Flag172;
+
+ procedure Set_Flag173 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag173 := Val;
+ end Set_Flag173;
+
+ procedure Set_Flag174 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag174 := Val;
+ end Set_Flag174;
+
+ procedure Set_Flag175 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag175 := Val;
+ end Set_Flag175;
+
+ procedure Set_Flag176 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag176 := Val;
+ end Set_Flag176;
+
+ procedure Set_Flag177 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag177 := Val;
+ end Set_Flag177;
+
+ procedure Set_Flag178 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag178 := Val;
+ end Set_Flag178;
+
+ procedure Set_Flag179 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag179 := Val;
+ end Set_Flag179;
+
+ procedure Set_Flag180 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag180 := Val;
+ end Set_Flag180;
+
+ procedure Set_Flag181 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag181 := Val;
+ end Set_Flag181;
+
+ procedure Set_Flag182 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag182 := Val;
+ end Set_Flag182;
+
+ procedure Set_Flag183 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word3_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag183 := Val;
+ end Set_Flag183;
+
+ procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val > Error then Set_Parent (Val, N); end if;
+ Set_Node1 (N, Val);
+ end Set_Node1_With_Parent;
+
+ procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val > Error then Set_Parent (Val, N); end if;
+ Set_Node2 (N, Val);
+ end Set_Node2_With_Parent;
+
+ procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val > Error then Set_Parent (Val, N); end if;
+ Set_Node3 (N, Val);
+ end Set_Node3_With_Parent;
+
+ procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val > Error then Set_Parent (Val, N); end if;
+ Set_Node4 (N, Val);
+ end Set_Node4_With_Parent;
+
+ procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val > Error then Set_Parent (Val, N); end if;
+ Set_Node5 (N, Val);
+ end Set_Node5_With_Parent;
+
+ procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val /= No_List and then Val /= Error_List then
+ Set_Parent (Val, N);
+ end if;
+ Set_List1 (N, Val);
+ end Set_List1_With_Parent;
+
+ procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val /= No_List and then Val /= Error_List then
+ Set_Parent (Val, N);
+ end if;
+ Set_List2 (N, Val);
+ end Set_List2_With_Parent;
+
+ procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val /= No_List and then Val /= Error_List then
+ Set_Parent (Val, N);
+ end if;
+ Set_List3 (N, Val);
+ end Set_List3_With_Parent;
+
+ procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val /= No_List and then Val /= Error_List then
+ Set_Parent (Val, N);
+ end if;
+ Set_List4 (N, Val);
+ end Set_List4_With_Parent;
+
+ procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (N in Nodes.First .. Nodes.Last);
+ if Val /= No_List and then Val /= Error_List then
+ Set_Parent (Val, N);
+ end if;
+ Set_List5 (N, Val);
+ end Set_List5_With_Parent;
+
+ end Unchecked_Access;
+
+end Atree;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A T R E E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.155 $
+-- --
+-- 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 Alloc;
+with Sinfo; use Sinfo;
+with Einfo; use Einfo;
+with Types; use Types;
+with Snames; use Snames;
+with System; use System;
+with Table;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Unchecked_Conversion;
+
+package Atree is
+
+-- This package defines the format of the tree used to represent the Ada
+-- program internally. Syntactic and semantic information is combined in
+-- this tree. There is no separate symbol table structure.
+
+-- WARNING: There is a C version of this package. Any changes to this
+-- source file must be properly reflected in the C header file tree.h
+
+-- Package Atree defines the basic structure of the tree and its nodes and
+-- provides the basic abstract interface for manipulating the tree. Two
+-- other packages use this interface to define the representation of Ada
+-- programs using this tree format. The package Sinfo defines the basic
+-- representation of the syntactic structure of the program, as output
+-- by the parser. The package Entity_Info defines the semantic information
+-- which is added to the tree nodes that represent declared entities (i.e.
+-- the information which might typically be described in a separate symbol
+-- table structure.
+
+-- The front end of the compiler first parses the program and generates a
+-- tree that is simply a syntactic representation of the program in abstract
+-- syntax tree format. Subsequent processing in the front end traverses the
+-- tree, transforming it in various ways and adding semantic information.
+
+ ----------------------------------------
+ -- Definitions of Fields in Tree Node --
+ ----------------------------------------
+
+ -- The representation of the tree is completely hidden, using a functional
+ -- interface for accessing and modifying the contents of nodes. Logically
+ -- a node contains a number of fields, much as though the nodes were
+ -- defined as a record type. The fields in a node are as follows:
+
+ -- Nkind Indicates the kind of the node. This field is present
+ -- in all nodes. The type is Node_Kind, which is declared
+ -- in the package Sinfo.
+
+ -- Sloc Location (Source_Ptr) of the corresponding token
+ -- in the Source buffer. The individual node definitions
+ -- show which token is referenced by this pointer.
+
+ -- In_List A flag used to indicate if the node is a member
+ -- of a node list.
+
+ -- Rewrite_Sub A flag set if the node has been rewritten using
+ -- the Rewrite procedure. The original value of the
+ -- node is retrievable with Original_Node.
+
+ -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
+ -- node as a result of a call to Mark_Rewrite_Insertion.
+
+ -- Paren_Count A 2-bit count used on expression nodes to indicate
+ -- the level of parentheses. Up to 3 levels can be
+ -- accomodated. Anything more than 3 levels is treated
+ -- as 3 levels (conformance tests that complain about
+ -- this are hereby deemed pathological!) Set to zero
+ -- for non-subexpression nodes.
+
+ -- Comes_From_Source
+ -- This flag is present in all nodes. It is set if the
+ -- node is built by the scanner or parser, and clear if
+ -- the node is built by the analyzer or expander. It
+ -- indicates that the node corresponds to a construct
+ -- that appears in the original source program.
+
+ -- Analyzed This flag is present in all nodes. It is set when
+ -- a node is analyzed, and is used to avoid analyzing
+ -- the same node twice. Analysis includes expansion if
+ -- expansion is active, so in this case if the flag is
+ -- set it means the node has been analyzed and expanded.
+
+ -- Error_Posted This flag is present in all nodes. It is set when
+ -- an error message is posted which is associated with
+ -- the flagged node. This is used to avoid posting more
+ -- than one message on the same node.
+
+ -- Field1
+ -- Field2
+ -- Field3
+ -- Field4
+ -- Field5 Five fields holding Union_Id values
+
+ -- Char_CodeN Synonym for FieldN typed as Char_Code
+ -- ElistN Synonym for FieldN typed as Elist_Id
+ -- ListN Synonym for FieldN typed as List_Id
+ -- NameN Synonym for FieldN typed as Name_Id
+ -- NodeN Synonym for FieldN typed as Node_Id
+ -- StrN Synonym for FieldN typed as String_Id
+ -- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
+ -- UrealN Synonym for FieldN typed as Ureal
+
+ -- Note: the actual usage of FieldN (i.e. whether it contains a Char_Code,
+ -- Elist_Id, List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal), depends
+ -- on the value in Nkind. Generally the access to this field is always via
+ -- the functional interface, so the field names Char_CodeN, ElistN, ListN,
+ -- NameN, NodeN, StrN, UintN and UrealN are used only in the bodies of the
+ -- access functions (i.e. in the bodies of Sinfo and Einfo). These access
+ -- functions contain debugging code that checks that the use is consistent
+ -- with Nkind and Ekind values.
+
+ -- However, in specialized circumstances (examples are the circuit in
+ -- generic instantiation to copy trees, and in the tree dump routine),
+ -- it is useful to be able to do untyped traversals, and an internal
+ -- package in Atree allows for direct untyped accesses in such cases.
+
+ -- Flag4 Fifteen Boolean flags (use depends on Nkind and
+ -- Flag5 Ekind, as described for Fieldn). Again the access
+ -- Flag6 is usually via subprograms in Sinfo and Einfo which
+ -- Flag7 provide high-level synonyms for these flags, and
+ -- Flag8 contain debugging code that checks that the values
+ -- Flag9 in Nkind and Ekind are appropriate for the access.
+ -- Flag10
+ -- Flag11 Note that Flag1-3 are missing from this list. The
+ -- Flag12 first three flag positions are reserved for the
+ -- Flag13 standard flags (Comes_From_Source, Error_Posted,
+ -- Flag14 and Analyzed)
+ -- Flag15
+ -- Flag16
+ -- Flag17
+ -- Flag18
+
+ -- Link For a node, points to the Parent. For a list, points
+ -- to the list header. Note that in the latter case, a
+ -- client cannot modify the link field. This field is
+ -- private to the Atree package (but is also modified
+ -- by the Nlists package).
+
+ -- The following additional fields are present in extended nodes used
+ -- for entities (Nkind in N_Entity).
+
+ -- Ekind Entity type. This field indicates the type of the
+ -- entity, it is of type Entity_Kind which is defined
+ -- in package Einfo.
+
+ -- Flag19 133 additional flags
+ -- ...
+ -- Flag151
+
+ -- Convention Entity convention (Convention_Id value)
+
+ -- Field6 Additional Union_Id value stored in tree
+
+ -- Node6 Synonym for Field6 typed as Node_Id
+ -- Elist6 Synonym for Field6 typed as Elist_Id
+ -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
+
+ -- Similar definitions for Field7 to Field23 (and Node7-Node23,
+ -- Elist7-Elist23, Uint7-Uint23, Ureal7-Ureal23). Note that not all
+ -- these functions are defined, only the ones that are actually used.
+
+ type Paren_Count_Type is mod 4;
+ for Paren_Count_Type'Size use 2;
+ -- Type used for Paren_Count field
+
+ function Last_Node_Id return Node_Id;
+ pragma Inline (Last_Node_Id);
+ -- Returns Id of last allocated node Id
+
+ function Nodes_Address return System.Address;
+ -- Return address of Nodes table (used in Back_End for Gigi call)
+
+ function Num_Nodes return Nat;
+ -- Total number of nodes allocated, where an entity counts as a single
+ -- node. This count is incremented every time a node or entity is
+ -- allocated, and decremented every time a node or entity is deleted.
+ -- This value is used by Xref and by Treepr to allocate hash tables of
+ -- suitable size for hashing Node_Id values.
+
+ -----------------------
+ -- Use of Empty Node --
+ -----------------------
+
+ -- The special Node_Id Empty is used to mark missing fields. Whenever the
+ -- syntax has an optional component, then the corresponding field will be
+ -- set to Empty if the component is missing.
+
+ -- Note: Empty is not used to describe an empty list. Instead in this
+ -- case the node field contains a list which is empty, and these cases
+ -- should be distinguished (essentially from a type point of view, Empty
+ -- is a Node, and is thus not a list).
+
+ -- Note: Empty does in fact correspond to an allocated node. Only the
+ -- Nkind field of this node may be referenced. It contains N_Empty, which
+ -- uniquely identifies the empty case. This allows the Nkind field to be
+ -- dereferenced before the check for Empty which is sometimes useful.
+
+ -----------------------
+ -- Use of Error Node --
+ -----------------------
+
+ -- The Error node is used during syntactic and semantic analysis to
+ -- indicate that the corresponding piece of syntactic structure or
+ -- semantic meaning cannot properly be represented in the tree because
+ -- of an illegality in the program.
+
+ -- If an Error node is encountered, then you know that a previous
+ -- illegality has been detected. The proper reaction should be to
+ -- avoid posting related cascaded error messages, and to propagate
+ -- the error node if necessary.
+
+ -----------------------
+ -- Current_Error_Node --
+ -----------------------
+
+ -- The current error node is a global location indicating the current
+ -- node that is being processed for the purposes of placing a compiler
+ -- abort message. This is not necessarily perfectly accurate, it is
+ -- just a reasonably accurate best guess. It is used to output the
+ -- source location in the abort message by Comperr, and also to
+ -- implement the d3 debugging flag. This is also used by Rtsfind
+ -- to generate error messages for No_Run_Time mode.
+
+ Current_Error_Node : Node_Id;
+ -- Node to place error messages
+
+ -------------------------------
+ -- Default Setting of Fields --
+ -------------------------------
+
+ -- Nkind is set to N_Unused_At_Start
+
+ -- Ekind is set to E_Void
+
+ -- Sloc is always set, there is no default value
+
+ -- Field1-5 fields are set to Empty
+
+ -- Field6-22 fields in extended nodes are set to Empty
+
+ -- Parent is set to Empty
+
+ -- All Boolean flag fields are set to False
+
+ -- Note: the value Empty is used in Field1-Field17 to indicate a null node.
+ -- The usage varies. The common uses are to indicate absence of an
+ -- optional clause or a completely unused Field1-17 field.
+
+ -------------------------------------
+ -- Use of Synonyms for Node Fields --
+ -------------------------------------
+
+ -- A subpackage Atree.Unchecked_Access provides routines for reading and
+ -- writing the fields defined above (Field1-17, Node1-17, Flag1-88 etc).
+ -- These unchecked access routines can be used for untyped traversals. In
+ -- In addition they are used in the implementations of the Sinfo and
+ -- Einfo packages. These packages both provide logical synonyms for
+ -- the generic fields, together with an appropriate set of access routines.
+ -- Normally access to information within tree nodes uses these synonyms,
+ -- providing a high level typed interface to the tree information.
+
+ --------------------------------------------------
+ -- Node Allocation and Modification Subprograms --
+ --------------------------------------------------
+
+ -- Generally the parser builds the tree and then it is further decorated
+ -- (e.g. by setting the entity fields), but not fundamentally modified.
+ -- However, there are cases in which the tree must be restructured by
+ -- adding and rearranging nodes, as a result of disambiguating cases
+ -- which the parser could not parse correctly, and adding additional
+ -- semantic information (e.g. making constraint checks explicit). The
+ -- following subprograms are used for constructing the tree in the first
+ -- place, and then for subsequent modifications as required
+
+ procedure Initialize;
+ -- Called at the start of compilation to initialize the allocation of
+ -- the node and list tables and make the standard entries for Empty,
+ -- Error and Error_List. Note that Initialize must not be called if
+ -- Tree_Read is used.
+
+ procedure Lock;
+ -- Called before the backend is invoked to lock the nodes table
+
+ procedure Tree_Read;
+ -- Initializes internal tables from current tree file using Tree_Read.
+ -- Note that Initialize should not be called if Tree_Read is used.
+ -- Tree_Read includes all necessary initialization.
+
+ procedure Tree_Write;
+ -- Writes out internal tables to current tree file using Tree_Write
+
+ function New_Node
+ (New_Node_Kind : Node_Kind;
+ New_Sloc : Source_Ptr)
+ return Node_Id;
+ -- Allocates a completely new node with the given node type and source
+ -- location values. All other fields are set to their standard defaults:
+ --
+ -- Empty for all Fieldn fields
+ -- False for all Flagn fields
+ --
+ -- The usual approach is to build a new node using this function and
+ -- then, using the value returned, use the Set_xxx functions to set
+ -- fields of the node as required. New_Node can only be used for
+ -- non-entity nodes, i.e. it never generates an extended node.
+
+ function New_Entity
+ (New_Node_Kind : Node_Kind;
+ New_Sloc : Source_Ptr)
+ return Entity_Id;
+ -- Similar to New_Node, except that it is used only for entity nodes
+ -- and returns an extended node.
+
+ procedure Set_Comes_From_Source_Default (Default : Boolean);
+ -- Sets value of Comes_From_Source flag to be used in all subsequent
+ -- New_Node and New_Entity calls until another call to this procedure
+ -- changes the default.
+
+ function Get_Comes_From_Source_Default return Boolean;
+ pragma Inline (Get_Comes_From_Source_Default);
+ -- Gets the current value of the Comes_From_Source flag
+
+ procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id);
+ pragma Inline (Preserve_Comes_From_Source);
+ -- When a node is rewritten, it is sometimes appropriate to preserve the
+ -- original comes from source indication. This is true when the rewrite
+ -- essentially corresponds to a transformation corresponding exactly to
+ -- semantics in the reference manual. This procedure copies the setting
+ -- of Comes_From_Source from OldN to NewN.
+
+ function Has_Extension (N : Node_Id) return Boolean;
+ pragma Inline (Has_Extension);
+ -- Returns True if the given node has an extension (i.e. was created by
+ -- a call to New_Entity rather than New_Node, and Nkind is in N_Entity)
+
+ procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind);
+ -- This procedure replaces the given node by setting its Nkind field to
+ -- the indicated value and resetting all other fields to their default
+ -- values except for Sloc, which is unchanged, and the Parent pointer
+ -- and list links, which are also unchanged. All other information in
+ -- the original node is lost. The new node has an extension if the
+ -- original node had an extension.
+
+ procedure Copy_Node (Source : Node_Id; Destination : Node_Id);
+ -- Copy the entire contents of the source node to the destination node.
+ -- The contents of the source node is not affected. If the source node
+ -- has an extension, then the destination must have an extension also.
+ -- The parent pointer of the destination and its list link, if any, are
+ -- not affected by the copy. Note that parent pointers of descendents
+ -- are not adjusted, so the descendents of the destination node after
+ -- the Copy_Node is completed have dubious parent pointers.
+
+ function New_Copy (Source : Node_Id) return Node_Id;
+ -- This function allocates a completely new node, and then initializes
+ -- it by copying the contents of the source node into it. The contents
+ -- of the source node is not affected. The target node is always marked
+ -- as not being in a list (even if the source is a list member). The
+ -- new node will have an extension if the source has an extension.
+ -- New_Copy (Empty) returns Empty and New_Copy (Error) returns Error.
+ -- Note that, unlike New_Copy_Tree, New_Copy does not recursively copy any
+ -- descendents, so in general parent pointers are not set correctly for
+ -- the descendents of the copied node. Both normal and extended nodes
+ -- (entities) may be copied using New_Copy.
+
+ function Relocate_Node (Source : Node_Id) return Node_Id;
+ -- Source is a non-entity node that is to be relocated. A new node is
+ -- allocated and the contents of Source are copied to this node using
+ -- Copy_Node. The parent pointers of descendents of the node are then
+ -- adjusted to point to the relocated copy. The original node is not
+ -- modified, but the parent pointers of its descendents are no longer
+ -- valid. This routine is used in conjunction with the tree rewrite
+ -- routines (see descriptions of Replace/Rewrite).
+ --
+ -- Note that the resulting node has the same parent as the source
+ -- node, and is thus still attached to the tree. It is valid for
+ -- Source to be Empty, in which case Relocate_Node simply returns
+ -- Empty as the result.
+
+ function New_Copy_Tree
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty)
+ return Node_Id;
+ -- Given a node that is the root of a subtree, Copy_Tree copies the entire
+ -- syntactic subtree, including recursively any descendents whose parent
+ -- field references a copied node (descendents not linked to a copied node
+ -- by the parent field are not copied, instead the copied tree references
+ -- the same descendent as the original in this case, which is appropriate
+ -- for non-syntactic fields such as Etype). The parent pointers in the
+ -- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error.
+ -- The one exception to the rule of not copying semantic fields is that
+ -- any implicit types attached to the subtree are duplicated, so that
+ -- the copy contains a distinct set of implicit type entities. The Map
+ -- argument, if set to a non-empty Elist, specifies a set of mappings
+ -- to be applied to entities in the tree. The map has the form:
+ --
+ -- old entity 1
+ -- new entity to replace references to entity 1
+ -- old entity 2
+ -- new entity to replace references to entity 2
+ -- ...
+ --
+ -- The call destroys the contents of Map in this case
+ --
+ -- The parameter New_Sloc, if set to a value other than No_Location, is
+ -- used as the Sloc value for all nodes in the new copy. If New_Sloc is
+ -- set to its default value No_Location, then the Sloc values of the
+ -- nodes in the copy are simply copied from the corresponding original.
+ --
+ -- The Comes_From_Source indication is unchanged if New_Sloc is set to
+ -- the default No_Location value, but is reset if New_Sloc is given, since
+ -- in this case the result clearly is neither a source node or an exact
+ -- copy of a source node.
+ --
+ -- The parameter New_Scope, if set to a value other than Empty, is the
+ -- value to use as the Scope for any Itypes that are copied. The most
+ -- typical value for this parameter, if given, is Current_Scope.
+
+ function Copy_Separate_Tree (Source : Node_Id) return Node_Id;
+ -- Given a node that is the root of a subtree, Copy_Separate_Tree copies
+ -- the entire syntactic subtree, including recursively any descendants
+ -- whose parent field references a copied node (descendants not linked to
+ -- a copied node by the parent field are also copied.) The parent pointers
+ -- in the copy are properly set. Copy_Separate_Tree (Empty/Error) returns
+ -- Empty/Error. The semantic fields are not copied and the new subtree
+ -- does not share any entity with source subtree.
+ -- But the code *does* copy semantic fields, and the description above
+ -- is in any case unclear on this point ??? (RBKD)
+
+ procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id);
+ -- Exchange the contents of two entities. The parent pointers are switched
+ -- as well as the Defining_Identifier fields in the parents, so that the
+ -- entities point correctly to their original parents. The effect is thus
+ -- to leave the tree completely unchanged in structure, except that the
+ -- entity ID values of the two entities are interchanged. Neither of the
+ -- two entities may be list members.
+
+ procedure Delete_Node (Node : Node_Id);
+ -- The node, which must not be a list member, is deleted from the tree and
+ -- its type is set to N_Unused_At_End. It is an error (not necessarily
+ -- detected) to reference this node after it has been deleted. The
+ -- implementation of the body of Atree is free to reuse the node to
+ -- satisfy future node allocation requests, but is not required to do so.
+
+ procedure Delete_Tree (Node : Node_Id);
+ -- The entire syntactic subtree referenced by Node (i.e. the given node
+ -- and all its syntactic descendents) are deleted as described above for
+ -- Delete_Node.
+
+ function Extend_Node (Node : Node_Id) return Entity_Id;
+ -- This function returns a copy of its input node with an extension
+ -- added. The fields of the extension are set to Empty. Due to the way
+ -- extensions are handled (as two consecutive array elements), it may
+ -- be necessary to reallocate the node, so that the returned value is
+ -- not the same as the input value, but where possible the returned
+ -- value will be the same as the input value (i.e. the extension will
+ -- occur in place). It is the caller's responsibility to ensure that
+ -- any pointers to the original node are appropriately updated. This
+ -- function is used only by Sinfo.CN to change nodes into their
+ -- corresponding entities.
+
+ type Traverse_Result is (OK, Skip, Abandon);
+ -- This is the type of the result returned by the Process function passed
+ -- to Traverse_Func and Traverse_Proc and also the type of the result of
+ -- Traverse_Func itself. See descriptions below for details.
+
+ generic
+ with function Process (N : Node_Id) return Traverse_Result is <>;
+ function Traverse_Func (Node : Node_Id) return Traverse_Result;
+ -- This is a generic function that, given the parent node for a subtree,
+ -- traverses all syntactic nodes of this tree, calling the given function
+ -- Process on each one. The traversal is controlled as follows by the
+ -- result returned by Process:
+
+ -- OK The traversal continues normally with the children of
+ -- the node just processed.
+
+ -- Skip The children of the node just processed are skipped and
+ -- excluded from the traversal, but otherwise processing
+ -- continues elsewhere in the tree.
+
+ -- Abandon The entire traversal is immediately abandoned, and the
+ -- original call to Traverse returns Abandon.
+
+ -- The result returned by Traverse is Abandon if processing was terminated
+ -- by a call to Process returning Abandon, otherwise it is OK (meaning that
+ -- all calls to process returned either OK or Skip).
+
+ generic
+ with function Process (N : Node_Id) return Traverse_Result is <>;
+ procedure Traverse_Proc (Node : Node_Id);
+ pragma Inline (Traverse_Proc);
+ -- This is similar to Traverse_Func except that no result is returned,
+ -- i.e. Traverse_Func is called and the result is simply discarded.
+
+ ---------------------------
+ -- Node Access Functions --
+ ---------------------------
+
+ -- The following functions return the contents of the indicated field of
+ -- the node referenced by the argument, which is a Node_Id.
+
+ function Nkind (N : Node_Id) return Node_Kind;
+ pragma Inline (Nkind);
+
+ function Analyzed (N : Node_Id) return Boolean;
+ pragma Inline (Analyzed);
+
+ function Comes_From_Source (N : Node_Id) return Boolean;
+ pragma Inline (Comes_From_Source);
+
+ function Error_Posted (N : Node_Id) return Boolean;
+ pragma Inline (Error_Posted);
+
+ function Sloc (N : Node_Id) return Source_Ptr;
+ pragma Inline (Sloc);
+
+ function Paren_Count (N : Node_Id) return Paren_Count_Type;
+ pragma Inline (Paren_Count);
+
+ function Parent (N : Node_Id) return Node_Id;
+ pragma Inline (Parent);
+ -- Returns the parent of a node if the node is not a list member, or
+ -- else the parent of the list containing the node if the node is a
+ -- list member.
+
+ function No (N : Node_Id) return Boolean;
+ pragma Inline (No);
+ -- Tests given Id for equality with the Empty node. This allows notations
+ -- like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty".
+
+ function Present (N : Node_Id) return Boolean;
+ pragma Inline (Present);
+ -- Tests given Id for inequality with the Empty node. This allows notations
+ -- like "if Present (Statement)" as opposed to "if Statement /= Empty".
+
+ -----------------------------
+ -- Entity Access Functions --
+ -----------------------------
+
+ -- The following functions apply only to Entity_Id values, i.e.
+ -- to extended nodes.
+
+ function Ekind (E : Entity_Id) return Entity_Kind;
+ pragma Inline (Ekind);
+
+ function Convention (E : Entity_Id) return Convention_Id;
+ pragma Inline (Convention);
+
+ ----------------------------
+ -- Node Update Procedures --
+ ----------------------------
+
+ -- The following functions set a specified field in the node whose Id is
+ -- passed as the first argument. The second parameter is the new value
+ -- to be set in the specified field. Note that Set_Nkind is in the next
+ -- section, since its use is restricted.
+
+ procedure Set_Sloc (N : Node_Id; Val : Source_Ptr);
+ pragma Inline (Set_Sloc);
+
+ procedure Set_Paren_Count (N : Node_Id; Val : Paren_Count_Type);
+ pragma Inline (Set_Paren_Count);
+
+ procedure Set_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Parent);
+
+ procedure Set_Analyzed (N : Node_Id; Val : Boolean := True);
+ pragma Inline (Set_Analyzed);
+
+ procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True);
+ pragma Inline (Set_Error_Posted);
+
+ procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Comes_From_Source);
+ -- Note that this routine is very rarely used, since usually the
+ -- default mechanism provided sets the right value, but in some
+ -- unusual cases, the value needs to be reset (e.g. when a source
+ -- node is copied, and the copy must not have Comes_From_Source set.
+
+ ------------------------------
+ -- Entity Update Procedures --
+ ------------------------------
+
+ -- The following procedures apply only to Entity_Id values, i.e.
+ -- to extended nodes.
+
+ procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind);
+ pragma Inline (Set_Ekind);
+
+ procedure Set_Convention (E : Entity_Id; Val : Convention_Id);
+ pragma Inline (Set_Convention);
+
+ ---------------------------
+ -- Tree Rewrite Routines --
+ ---------------------------
+
+ -- During the compilation process it is necessary in a number of situations
+ -- to rewrite the tree. In some cases, such rewrites do not affect the
+ -- structure of the tree, for example, when an indexed component node is
+ -- replaced by the corresponding call node (the parser cannot distinguish
+ -- between these two cases).
+
+ -- In other situations, the rewrite does affect the structure of the
+ -- tree. Examples are the replacement of a generic instantiation by the
+ -- instantiated spec and body, and the static evaluation of expressions.
+
+ -- If such structural modifications are done by the expander, there are
+ -- no difficulties, since the form of the tree after the expander has no
+ -- special significance, except as input to the backend of the compiler.
+ -- However, if these modifications are done by the semantic phase, then
+ -- it is important that they be done in a manner which allows the original
+ -- tree to be preserved. This is because tools like pretty printers need
+ -- to have this original tree structure available.
+
+ -- The subprograms in this section allow rewriting of the tree by either
+ -- insertion of new nodes in an existing list, or complete replacement of
+ -- a subtree. The resulting tree for most purposes looks as though it has
+ -- been really changed, and there is no trace of the original. However,
+ -- special subprograms, also defined in this section, allow the original
+ -- tree to be reconstructed if necessary.
+
+ -- For tree modifications done in the expander, it is permissible to
+ -- destroy the original tree, although it is also allowable to use the
+ -- tree rewrite routines where it is convenient to do so.
+
+ procedure Mark_Rewrite_Insertion (New_Node : Node_Id);
+ pragma Inline (Mark_Rewrite_Insertion);
+ -- This procedure marks the given node as an insertion made during a tree
+ -- rewriting operation. Only the root needs to be marked. The call does
+ -- not do the actual insertion, which must be done using one of the normal
+ -- list insertion routines. The node is treated normally in all respects
+ -- except for its response to Is_Rewrite_Insertion. The function of these
+ -- calls is to be able to get an accurate original tree. This helps the
+ -- accuracy of Sprint.Sprint_Node, and in particular, when stubs are being
+ -- generated, it is essential that the original tree be accurate.
+
+ function Is_Rewrite_Insertion (Node : Node_Id) return Boolean;
+ pragma Inline (Is_Rewrite_Insertion);
+ -- Tests whether the given node was marked using Set_Rewrite_Insert. This
+ -- is used in reconstructing the original tree (where such nodes are to
+ -- be eliminated from the reconstructed tree).
+
+ procedure Rewrite (Old_Node, New_Node : Node_Id);
+ -- This is used when a complete subtree is to be replaced. Old_Node is the
+ -- root of the old subtree to be replaced, and New_Node is the root of the
+ -- newly constructed replacement subtree. The actual mechanism is to swap
+ -- the contents of these two nodes fixing up the parent pointers of the
+ -- replaced node (we do not attempt to preserve parent pointers for the
+ -- original node). Neither Old_Node nor New_Node can be extended nodes.
+ --
+ -- Note: New_Node may not contain references to Old_Node, for example as
+ -- descendents, since the rewrite would make such references invalid. If
+ -- New_Node does need to reference Old_Node, then these references should
+ -- be to a relocated copy of Old_Node (see Relocate_Node procedure).
+ --
+ -- Note: The Original_Node function applied to Old_Node (which has now
+ -- been replaced by the contents of New_Node), can be used to obtain the
+ -- original node, i.e. the old contents of Old_Node.
+
+ procedure Replace (Old_Node, New_Node : Node_Id);
+ -- This is similar to Rewrite, except that the old value of Old_Node is
+ -- not saved, and the New_Node is deleted after the replace, since it
+ -- is assumed that it can no longer be legitimately needed. The flag
+ -- Is_Rewrite_Susbtitute will be False for the resulting node, unless
+ -- it was already true on entry, and Original_Node will not return the
+ -- original contents of the Old_Node, but rather the New_Node value (unless
+ -- Old_Node had already been rewritten using Rewrite). Replace also
+ -- preserves the setting of Comes_From_Source.
+ --
+ -- Note, New_Node may not contain references to Old_Node, for example as
+ -- descendents, since the rewrite would make such references invalid. If
+ -- New_Node does need to reference Old_Node, then these references should
+ -- be to a relocated copy of Old_Node (see Relocate_Node procedure).
+ --
+ -- Replace is used in certain circumstances where it is desirable to
+ -- suppress any history of the rewriting operation. Notably, it is used
+ -- when the parser has mis-classified a node (e.g. a task entry call
+ -- that the parser has parsed as a procedure call).
+
+ function Is_Rewrite_Substitution (Node : Node_Id) return Boolean;
+ pragma Inline (Is_Rewrite_Substitution);
+ -- Return True iff Node has been rewritten (i.e. if Node is the root
+ -- of a subtree which was installed using Rewrite).
+
+ function Original_Node (Node : Node_Id) return Node_Id;
+ pragma Inline (Original_Node);
+ -- If Node has not been rewritten, then returns its input argument
+ -- unchanged, else returns the Node for the original subtree.
+ --
+ -- Note: Parents are not preserved in original tree nodes that are
+ -- retrieved in this way (i.e. their children may have children whose
+ -- pointers which reference some other node).
+
+ -- Note: there is no direct mechanism for deleting an original node (in
+ -- a manner that can be reversed later). One possible approach is to use
+ -- Rewrite to substitute a null statement for the node to be deleted.
+
+ -----------------------------------
+ -- Generic Field Access Routines --
+ -----------------------------------
+
+ -- This subpackage provides the functions for accessing and procedures
+ -- for setting fields that are normally referenced by their logical
+ -- synonyms defined in packages Sinfo and Einfo. As previously
+ -- described the implementations of these packages use the package
+ -- Atree.Unchecked_Access.
+
+ package Unchecked_Access is
+
+ -- Functions to allow interpretation of Union_Id values as Uint
+ -- and Ureal values
+
+ function To_Union is new Unchecked_Conversion (Uint, Union_Id);
+ function To_Union is new Unchecked_Conversion (Ureal, Union_Id);
+
+ function From_Union is new Unchecked_Conversion (Union_Id, Uint);
+ function From_Union is new Unchecked_Conversion (Union_Id, Ureal);
+
+ -- Functions to fetch contents of indicated field. It is an error
+ -- to attempt to read the value of a field which is not present.
+
+ function Field1 (N : Node_Id) return Union_Id;
+ pragma Inline (Field1);
+
+ function Field2 (N : Node_Id) return Union_Id;
+ pragma Inline (Field2);
+
+ function Field3 (N : Node_Id) return Union_Id;
+ pragma Inline (Field3);
+
+ function Field4 (N : Node_Id) return Union_Id;
+ pragma Inline (Field4);
+
+ function Field5 (N : Node_Id) return Union_Id;
+ pragma Inline (Field5);
+
+ function Field6 (N : Node_Id) return Union_Id;
+ pragma Inline (Field6);
+
+ function Field7 (N : Node_Id) return Union_Id;
+ pragma Inline (Field7);
+
+ function Field8 (N : Node_Id) return Union_Id;
+ pragma Inline (Field8);
+
+ function Field9 (N : Node_Id) return Union_Id;
+ pragma Inline (Field9);
+
+ function Field10 (N : Node_Id) return Union_Id;
+ pragma Inline (Field10);
+
+ function Field11 (N : Node_Id) return Union_Id;
+ pragma Inline (Field11);
+
+ function Field12 (N : Node_Id) return Union_Id;
+ pragma Inline (Field12);
+
+ function Field13 (N : Node_Id) return Union_Id;
+ pragma Inline (Field13);
+
+ function Field14 (N : Node_Id) return Union_Id;
+ pragma Inline (Field14);
+
+ function Field15 (N : Node_Id) return Union_Id;
+ pragma Inline (Field15);
+
+ function Field16 (N : Node_Id) return Union_Id;
+ pragma Inline (Field16);
+
+ function Field17 (N : Node_Id) return Union_Id;
+ pragma Inline (Field17);
+
+ function Field18 (N : Node_Id) return Union_Id;
+ pragma Inline (Field18);
+
+ function Field19 (N : Node_Id) return Union_Id;
+ pragma Inline (Field19);
+
+ function Field20 (N : Node_Id) return Union_Id;
+ pragma Inline (Field20);
+
+ function Field21 (N : Node_Id) return Union_Id;
+ pragma Inline (Field21);
+
+ function Field22 (N : Node_Id) return Union_Id;
+ pragma Inline (Field22);
+
+ function Field23 (N : Node_Id) return Union_Id;
+ pragma Inline (Field23);
+
+ function Node1 (N : Node_Id) return Node_Id;
+ pragma Inline (Node1);
+
+ function Node2 (N : Node_Id) return Node_Id;
+ pragma Inline (Node2);
+
+ function Node3 (N : Node_Id) return Node_Id;
+ pragma Inline (Node3);
+
+ function Node4 (N : Node_Id) return Node_Id;
+ pragma Inline (Node4);
+
+ function Node5 (N : Node_Id) return Node_Id;
+ pragma Inline (Node5);
+
+ function Node6 (N : Node_Id) return Node_Id;
+ pragma Inline (Node6);
+
+ function Node7 (N : Node_Id) return Node_Id;
+ pragma Inline (Node7);
+
+ function Node8 (N : Node_Id) return Node_Id;
+ pragma Inline (Node8);
+
+ function Node9 (N : Node_Id) return Node_Id;
+ pragma Inline (Node9);
+
+ function Node10 (N : Node_Id) return Node_Id;
+ pragma Inline (Node10);
+
+ function Node11 (N : Node_Id) return Node_Id;
+ pragma Inline (Node11);
+
+ function Node12 (N : Node_Id) return Node_Id;
+ pragma Inline (Node12);
+
+ function Node13 (N : Node_Id) return Node_Id;
+ pragma Inline (Node13);
+
+ function Node14 (N : Node_Id) return Node_Id;
+ pragma Inline (Node14);
+
+ function Node15 (N : Node_Id) return Node_Id;
+ pragma Inline (Node15);
+
+ function Node16 (N : Node_Id) return Node_Id;
+ pragma Inline (Node16);
+
+ function Node17 (N : Node_Id) return Node_Id;
+ pragma Inline (Node17);
+
+ function Node18 (N : Node_Id) return Node_Id;
+ pragma Inline (Node18);
+
+ function Node19 (N : Node_Id) return Node_Id;
+ pragma Inline (Node19);
+
+ function Node20 (N : Node_Id) return Node_Id;
+ pragma Inline (Node20);
+
+ function Node21 (N : Node_Id) return Node_Id;
+ pragma Inline (Node21);
+
+ function Node22 (N : Node_Id) return Node_Id;
+ pragma Inline (Node22);
+
+ function Node23 (N : Node_Id) return Node_Id;
+ pragma Inline (Node23);
+
+ function List1 (N : Node_Id) return List_Id;
+ pragma Inline (List1);
+
+ function List2 (N : Node_Id) return List_Id;
+ pragma Inline (List2);
+
+ function List3 (N : Node_Id) return List_Id;
+ pragma Inline (List3);
+
+ function List4 (N : Node_Id) return List_Id;
+ pragma Inline (List4);
+
+ function List5 (N : Node_Id) return List_Id;
+ pragma Inline (List5);
+
+ function List10 (N : Node_Id) return List_Id;
+ pragma Inline (List10);
+
+ function List14 (N : Node_Id) return List_Id;
+ pragma Inline (List14);
+
+ function Elist2 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist2);
+
+ function Elist3 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist3);
+
+ function Elist4 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist4);
+
+ function Elist8 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist8);
+
+ function Elist13 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist13);
+
+ function Elist15 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist15);
+
+ function Elist16 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist16);
+
+ function Elist18 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist18);
+
+ function Elist21 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist21);
+
+ function Elist23 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist23);
+
+ function Name1 (N : Node_Id) return Name_Id;
+ pragma Inline (Name1);
+
+ function Name2 (N : Node_Id) return Name_Id;
+ pragma Inline (Name2);
+
+ function Char_Code2 (N : Node_Id) return Char_Code;
+ pragma Inline (Char_Code2);
+
+ function Str3 (N : Node_Id) return String_Id;
+ pragma Inline (Str3);
+
+ -- Note: the following Uintnn functions have a special test for
+ -- the Field value being Empty. If an Empty value is found then
+ -- Uint_0 is returned. This avoids the rather tricky requirement
+ -- of initializing all Uint fields in nodes and entities.
+
+ function Uint3 (N : Node_Id) return Uint;
+ pragma Inline (Uint3);
+
+ function Uint4 (N : Node_Id) return Uint;
+ pragma Inline (Uint4);
+
+ function Uint5 (N : Node_Id) return Uint;
+ pragma Inline (Uint5);
+
+ function Uint8 (N : Node_Id) return Uint;
+ pragma Inline (Uint8);
+
+ function Uint9 (N : Node_Id) return Uint;
+ pragma Inline (Uint9);
+
+ function Uint10 (N : Node_Id) return Uint;
+ pragma Inline (Uint10);
+
+ function Uint11 (N : Node_Id) return Uint;
+ pragma Inline (Uint11);
+
+ function Uint12 (N : Node_Id) return Uint;
+ pragma Inline (Uint12);
+
+ function Uint13 (N : Node_Id) return Uint;
+ pragma Inline (Uint13);
+
+ function Uint14 (N : Node_Id) return Uint;
+ pragma Inline (Uint14);
+
+ function Uint15 (N : Node_Id) return Uint;
+ pragma Inline (Uint15);
+
+ function Uint16 (N : Node_Id) return Uint;
+ pragma Inline (Uint16);
+
+ function Uint17 (N : Node_Id) return Uint;
+ pragma Inline (Uint17);
+
+ function Uint22 (N : Node_Id) return Uint;
+ pragma Inline (Uint22);
+
+ function Ureal3 (N : Node_Id) return Ureal;
+ pragma Inline (Ureal3);
+
+ function Ureal18 (N : Node_Id) return Ureal;
+ pragma Inline (Ureal18);
+
+ function Ureal21 (N : Node_Id) return Ureal;
+ pragma Inline (Ureal21);
+
+ function Flag4 (N : Node_Id) return Boolean;
+ pragma Inline (Flag4);
+
+ function Flag5 (N : Node_Id) return Boolean;
+ pragma Inline (Flag5);
+
+ function Flag6 (N : Node_Id) return Boolean;
+ pragma Inline (Flag6);
+
+ function Flag7 (N : Node_Id) return Boolean;
+ pragma Inline (Flag7);
+
+ function Flag8 (N : Node_Id) return Boolean;
+ pragma Inline (Flag8);
+
+ function Flag9 (N : Node_Id) return Boolean;
+ pragma Inline (Flag9);
+
+ function Flag10 (N : Node_Id) return Boolean;
+ pragma Inline (Flag10);
+
+ function Flag11 (N : Node_Id) return Boolean;
+ pragma Inline (Flag11);
+
+ function Flag12 (N : Node_Id) return Boolean;
+ pragma Inline (Flag12);
+
+ function Flag13 (N : Node_Id) return Boolean;
+ pragma Inline (Flag13);
+
+ function Flag14 (N : Node_Id) return Boolean;
+ pragma Inline (Flag14);
+
+ function Flag15 (N : Node_Id) return Boolean;
+ pragma Inline (Flag15);
+
+ function Flag16 (N : Node_Id) return Boolean;
+ pragma Inline (Flag16);
+
+ function Flag17 (N : Node_Id) return Boolean;
+ pragma Inline (Flag17);
+
+ function Flag18 (N : Node_Id) return Boolean;
+ pragma Inline (Flag18);
+
+ function Flag19 (N : Node_Id) return Boolean;
+ pragma Inline (Flag19);
+
+ function Flag20 (N : Node_Id) return Boolean;
+ pragma Inline (Flag20);
+
+ function Flag21 (N : Node_Id) return Boolean;
+ pragma Inline (Flag21);
+
+ function Flag22 (N : Node_Id) return Boolean;
+ pragma Inline (Flag22);
+
+ function Flag23 (N : Node_Id) return Boolean;
+ pragma Inline (Flag23);
+
+ function Flag24 (N : Node_Id) return Boolean;
+ pragma Inline (Flag24);
+
+ function Flag25 (N : Node_Id) return Boolean;
+ pragma Inline (Flag25);
+
+ function Flag26 (N : Node_Id) return Boolean;
+ pragma Inline (Flag26);
+
+ function Flag27 (N : Node_Id) return Boolean;
+ pragma Inline (Flag27);
+
+ function Flag28 (N : Node_Id) return Boolean;
+ pragma Inline (Flag28);
+
+ function Flag29 (N : Node_Id) return Boolean;
+ pragma Inline (Flag29);
+
+ function Flag30 (N : Node_Id) return Boolean;
+ pragma Inline (Flag30);
+
+ function Flag31 (N : Node_Id) return Boolean;
+ pragma Inline (Flag31);
+
+ function Flag32 (N : Node_Id) return Boolean;
+ pragma Inline (Flag32);
+
+ function Flag33 (N : Node_Id) return Boolean;
+ pragma Inline (Flag33);
+
+ function Flag34 (N : Node_Id) return Boolean;
+ pragma Inline (Flag34);
+
+ function Flag35 (N : Node_Id) return Boolean;
+ pragma Inline (Flag35);
+
+ function Flag36 (N : Node_Id) return Boolean;
+ pragma Inline (Flag36);
+
+ function Flag37 (N : Node_Id) return Boolean;
+ pragma Inline (Flag37);
+
+ function Flag38 (N : Node_Id) return Boolean;
+ pragma Inline (Flag38);
+
+ function Flag39 (N : Node_Id) return Boolean;
+ pragma Inline (Flag39);
+
+ function Flag40 (N : Node_Id) return Boolean;
+ pragma Inline (Flag40);
+
+ function Flag41 (N : Node_Id) return Boolean;
+ pragma Inline (Flag41);
+
+ function Flag42 (N : Node_Id) return Boolean;
+ pragma Inline (Flag42);
+
+ function Flag43 (N : Node_Id) return Boolean;
+ pragma Inline (Flag43);
+
+ function Flag44 (N : Node_Id) return Boolean;
+ pragma Inline (Flag44);
+
+ function Flag45 (N : Node_Id) return Boolean;
+ pragma Inline (Flag45);
+
+ function Flag46 (N : Node_Id) return Boolean;
+ pragma Inline (Flag46);
+
+ function Flag47 (N : Node_Id) return Boolean;
+ pragma Inline (Flag47);
+
+ function Flag48 (N : Node_Id) return Boolean;
+ pragma Inline (Flag48);
+
+ function Flag49 (N : Node_Id) return Boolean;
+ pragma Inline (Flag49);
+
+ function Flag50 (N : Node_Id) return Boolean;
+ pragma Inline (Flag50);
+
+ function Flag51 (N : Node_Id) return Boolean;
+ pragma Inline (Flag51);
+
+ function Flag52 (N : Node_Id) return Boolean;
+ pragma Inline (Flag52);
+
+ function Flag53 (N : Node_Id) return Boolean;
+ pragma Inline (Flag53);
+
+ function Flag54 (N : Node_Id) return Boolean;
+ pragma Inline (Flag54);
+
+ function Flag55 (N : Node_Id) return Boolean;
+ pragma Inline (Flag55);
+
+ function Flag56 (N : Node_Id) return Boolean;
+ pragma Inline (Flag56);
+
+ function Flag57 (N : Node_Id) return Boolean;
+ pragma Inline (Flag57);
+
+ function Flag58 (N : Node_Id) return Boolean;
+ pragma Inline (Flag58);
+
+ function Flag59 (N : Node_Id) return Boolean;
+ pragma Inline (Flag59);
+
+ function Flag60 (N : Node_Id) return Boolean;
+ pragma Inline (Flag60);
+
+ function Flag61 (N : Node_Id) return Boolean;
+ pragma Inline (Flag61);
+
+ function Flag62 (N : Node_Id) return Boolean;
+ pragma Inline (Flag62);
+
+ function Flag63 (N : Node_Id) return Boolean;
+ pragma Inline (Flag63);
+
+ function Flag64 (N : Node_Id) return Boolean;
+ pragma Inline (Flag64);
+
+ function Flag65 (N : Node_Id) return Boolean;
+ pragma Inline (Flag65);
+
+ function Flag66 (N : Node_Id) return Boolean;
+ pragma Inline (Flag66);
+
+ function Flag67 (N : Node_Id) return Boolean;
+ pragma Inline (Flag67);
+
+ function Flag68 (N : Node_Id) return Boolean;
+ pragma Inline (Flag68);
+
+ function Flag69 (N : Node_Id) return Boolean;
+ pragma Inline (Flag69);
+
+ function Flag70 (N : Node_Id) return Boolean;
+ pragma Inline (Flag70);
+
+ function Flag71 (N : Node_Id) return Boolean;
+ pragma Inline (Flag71);
+
+ function Flag72 (N : Node_Id) return Boolean;
+ pragma Inline (Flag72);
+
+ function Flag73 (N : Node_Id) return Boolean;
+ pragma Inline (Flag73);
+
+ function Flag74 (N : Node_Id) return Boolean;
+ pragma Inline (Flag74);
+
+ function Flag75 (N : Node_Id) return Boolean;
+ pragma Inline (Flag75);
+
+ function Flag76 (N : Node_Id) return Boolean;
+ pragma Inline (Flag76);
+
+ function Flag77 (N : Node_Id) return Boolean;
+ pragma Inline (Flag77);
+
+ function Flag78 (N : Node_Id) return Boolean;
+ pragma Inline (Flag78);
+
+ function Flag79 (N : Node_Id) return Boolean;
+ pragma Inline (Flag79);
+
+ function Flag80 (N : Node_Id) return Boolean;
+ pragma Inline (Flag80);
+
+ function Flag81 (N : Node_Id) return Boolean;
+ pragma Inline (Flag81);
+
+ function Flag82 (N : Node_Id) return Boolean;
+ pragma Inline (Flag82);
+
+ function Flag83 (N : Node_Id) return Boolean;
+ pragma Inline (Flag83);
+
+ function Flag84 (N : Node_Id) return Boolean;
+ pragma Inline (Flag84);
+
+ function Flag85 (N : Node_Id) return Boolean;
+ pragma Inline (Flag85);
+
+ function Flag86 (N : Node_Id) return Boolean;
+ pragma Inline (Flag86);
+
+ function Flag87 (N : Node_Id) return Boolean;
+ pragma Inline (Flag87);
+
+ function Flag88 (N : Node_Id) return Boolean;
+ pragma Inline (Flag88);
+
+ function Flag89 (N : Node_Id) return Boolean;
+ pragma Inline (Flag89);
+
+ function Flag90 (N : Node_Id) return Boolean;
+ pragma Inline (Flag90);
+
+ function Flag91 (N : Node_Id) return Boolean;
+ pragma Inline (Flag91);
+
+ function Flag92 (N : Node_Id) return Boolean;
+ pragma Inline (Flag92);
+
+ function Flag93 (N : Node_Id) return Boolean;
+ pragma Inline (Flag93);
+
+ function Flag94 (N : Node_Id) return Boolean;
+ pragma Inline (Flag94);
+
+ function Flag95 (N : Node_Id) return Boolean;
+ pragma Inline (Flag95);
+
+ function Flag96 (N : Node_Id) return Boolean;
+ pragma Inline (Flag96);
+
+ function Flag97 (N : Node_Id) return Boolean;
+ pragma Inline (Flag97);
+
+ function Flag98 (N : Node_Id) return Boolean;
+ pragma Inline (Flag98);
+
+ function Flag99 (N : Node_Id) return Boolean;
+ pragma Inline (Flag99);
+
+ function Flag100 (N : Node_Id) return Boolean;
+ pragma Inline (Flag100);
+
+ function Flag101 (N : Node_Id) return Boolean;
+ pragma Inline (Flag101);
+
+ function Flag102 (N : Node_Id) return Boolean;
+ pragma Inline (Flag102);
+
+ function Flag103 (N : Node_Id) return Boolean;
+ pragma Inline (Flag103);
+
+ function Flag104 (N : Node_Id) return Boolean;
+ pragma Inline (Flag104);
+
+ function Flag105 (N : Node_Id) return Boolean;
+ pragma Inline (Flag105);
+
+ function Flag106 (N : Node_Id) return Boolean;
+ pragma Inline (Flag106);
+
+ function Flag107 (N : Node_Id) return Boolean;
+ pragma Inline (Flag107);
+
+ function Flag108 (N : Node_Id) return Boolean;
+ pragma Inline (Flag108);
+
+ function Flag109 (N : Node_Id) return Boolean;
+ pragma Inline (Flag109);
+
+ function Flag110 (N : Node_Id) return Boolean;
+ pragma Inline (Flag110);
+
+ function Flag111 (N : Node_Id) return Boolean;
+ pragma Inline (Flag111);
+
+ function Flag112 (N : Node_Id) return Boolean;
+ pragma Inline (Flag112);
+
+ function Flag113 (N : Node_Id) return Boolean;
+ pragma Inline (Flag113);
+
+ function Flag114 (N : Node_Id) return Boolean;
+ pragma Inline (Flag114);
+
+ function Flag115 (N : Node_Id) return Boolean;
+ pragma Inline (Flag115);
+
+ function Flag116 (N : Node_Id) return Boolean;
+ pragma Inline (Flag116);
+
+ function Flag117 (N : Node_Id) return Boolean;
+ pragma Inline (Flag117);
+
+ function Flag118 (N : Node_Id) return Boolean;
+ pragma Inline (Flag118);
+
+ function Flag119 (N : Node_Id) return Boolean;
+ pragma Inline (Flag119);
+
+ function Flag120 (N : Node_Id) return Boolean;
+ pragma Inline (Flag120);
+
+ function Flag121 (N : Node_Id) return Boolean;
+ pragma Inline (Flag121);
+
+ function Flag122 (N : Node_Id) return Boolean;
+ pragma Inline (Flag122);
+
+ function Flag123 (N : Node_Id) return Boolean;
+ pragma Inline (Flag123);
+
+ function Flag124 (N : Node_Id) return Boolean;
+ pragma Inline (Flag124);
+
+ function Flag125 (N : Node_Id) return Boolean;
+ pragma Inline (Flag125);
+
+ function Flag126 (N : Node_Id) return Boolean;
+ pragma Inline (Flag126);
+
+ function Flag127 (N : Node_Id) return Boolean;
+ pragma Inline (Flag127);
+
+ function Flag128 (N : Node_Id) return Boolean;
+ pragma Inline (Flag128);
+
+ function Flag129 (N : Node_Id) return Boolean;
+ pragma Inline (Flag129);
+
+ function Flag130 (N : Node_Id) return Boolean;
+ pragma Inline (Flag130);
+
+ function Flag131 (N : Node_Id) return Boolean;
+ pragma Inline (Flag131);
+
+ function Flag132 (N : Node_Id) return Boolean;
+ pragma Inline (Flag132);
+
+ function Flag133 (N : Node_Id) return Boolean;
+ pragma Inline (Flag133);
+
+ function Flag134 (N : Node_Id) return Boolean;
+ pragma Inline (Flag134);
+
+ function Flag135 (N : Node_Id) return Boolean;
+ pragma Inline (Flag135);
+
+ function Flag136 (N : Node_Id) return Boolean;
+ pragma Inline (Flag136);
+
+ function Flag137 (N : Node_Id) return Boolean;
+ pragma Inline (Flag137);
+
+ function Flag138 (N : Node_Id) return Boolean;
+ pragma Inline (Flag138);
+
+ function Flag139 (N : Node_Id) return Boolean;
+ pragma Inline (Flag139);
+
+ function Flag140 (N : Node_Id) return Boolean;
+ pragma Inline (Flag140);
+
+ function Flag141 (N : Node_Id) return Boolean;
+ pragma Inline (Flag141);
+
+ function Flag142 (N : Node_Id) return Boolean;
+ pragma Inline (Flag142);
+
+ function Flag143 (N : Node_Id) return Boolean;
+ pragma Inline (Flag143);
+
+ function Flag144 (N : Node_Id) return Boolean;
+ pragma Inline (Flag144);
+
+ function Flag145 (N : Node_Id) return Boolean;
+ pragma Inline (Flag145);
+
+ function Flag146 (N : Node_Id) return Boolean;
+ pragma Inline (Flag146);
+
+ function Flag147 (N : Node_Id) return Boolean;
+ pragma Inline (Flag147);
+
+ function Flag148 (N : Node_Id) return Boolean;
+ pragma Inline (Flag148);
+
+ function Flag149 (N : Node_Id) return Boolean;
+ pragma Inline (Flag149);
+
+ function Flag150 (N : Node_Id) return Boolean;
+ pragma Inline (Flag150);
+
+ function Flag151 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag152 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag153 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag154 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag155 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag156 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag157 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag158 (N : Node_Id) return Boolean;
+ pragma Inline (Flag151);
+
+ function Flag159 (N : Node_Id) return Boolean;
+ pragma Inline (Flag159);
+
+ function Flag160 (N : Node_Id) return Boolean;
+ pragma Inline (Flag160);
+
+ function Flag161 (N : Node_Id) return Boolean;
+ pragma Inline (Flag161);
+
+ function Flag162 (N : Node_Id) return Boolean;
+ pragma Inline (Flag162);
+
+ function Flag163 (N : Node_Id) return Boolean;
+ pragma Inline (Flag163);
+
+ function Flag164 (N : Node_Id) return Boolean;
+ pragma Inline (Flag164);
+
+ function Flag165 (N : Node_Id) return Boolean;
+ pragma Inline (Flag165);
+
+ function Flag166 (N : Node_Id) return Boolean;
+ pragma Inline (Flag166);
+
+ function Flag167 (N : Node_Id) return Boolean;
+ pragma Inline (Flag167);
+
+ function Flag168 (N : Node_Id) return Boolean;
+ pragma Inline (Flag168);
+
+ function Flag169 (N : Node_Id) return Boolean;
+ pragma Inline (Flag169);
+
+ function Flag170 (N : Node_Id) return Boolean;
+ pragma Inline (Flag170);
+
+ function Flag171 (N : Node_Id) return Boolean;
+ pragma Inline (Flag171);
+
+ function Flag172 (N : Node_Id) return Boolean;
+ pragma Inline (Flag172);
+
+ function Flag173 (N : Node_Id) return Boolean;
+ pragma Inline (Flag173);
+
+ function Flag174 (N : Node_Id) return Boolean;
+ pragma Inline (Flag174);
+
+ function Flag175 (N : Node_Id) return Boolean;
+ pragma Inline (Flag175);
+
+ function Flag176 (N : Node_Id) return Boolean;
+ pragma Inline (Flag176);
+
+ function Flag177 (N : Node_Id) return Boolean;
+ pragma Inline (Flag177);
+
+ function Flag178 (N : Node_Id) return Boolean;
+ pragma Inline (Flag178);
+
+ function Flag179 (N : Node_Id) return Boolean;
+ pragma Inline (Flag179);
+
+ function Flag180 (N : Node_Id) return Boolean;
+ pragma Inline (Flag180);
+
+ function Flag181 (N : Node_Id) return Boolean;
+ pragma Inline (Flag181);
+
+ function Flag182 (N : Node_Id) return Boolean;
+ pragma Inline (Flag182);
+
+ function Flag183 (N : Node_Id) return Boolean;
+ pragma Inline (Flag183);
+
+ -- Procedures to set value of indicated field
+
+ procedure Set_Nkind (N : Node_Id; Val : Node_Kind);
+ pragma Inline (Set_Nkind);
+
+ procedure Set_Field1 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field1);
+
+ procedure Set_Field2 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field2);
+
+ procedure Set_Field3 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field3);
+
+ procedure Set_Field4 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field4);
+
+ procedure Set_Field5 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field5);
+
+ procedure Set_Field6 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field6);
+
+ procedure Set_Field7 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field7);
+
+ procedure Set_Field8 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field8);
+
+ procedure Set_Field9 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field9);
+
+ procedure Set_Field10 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field10);
+
+ procedure Set_Field11 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field11);
+
+ procedure Set_Field12 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field12);
+
+ procedure Set_Field13 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field13);
+
+ procedure Set_Field14 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field14);
+
+ procedure Set_Field15 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field15);
+
+ procedure Set_Field16 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field16);
+
+ procedure Set_Field17 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field17);
+
+ procedure Set_Field18 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field18);
+
+ procedure Set_Field19 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field19);
+
+ procedure Set_Field20 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field20);
+
+ procedure Set_Field21 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field21);
+
+ procedure Set_Field22 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field22);
+
+ procedure Set_Field23 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field23);
+
+ procedure Set_Node1 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node1);
+
+ procedure Set_Node2 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node2);
+
+ procedure Set_Node3 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node3);
+
+ procedure Set_Node4 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node4);
+
+ procedure Set_Node5 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node5);
+
+ procedure Set_Node6 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node6);
+
+ procedure Set_Node7 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node7);
+
+ procedure Set_Node8 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node8);
+
+ procedure Set_Node9 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node9);
+
+ procedure Set_Node10 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node10);
+
+ procedure Set_Node11 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node11);
+
+ procedure Set_Node12 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node12);
+
+ procedure Set_Node13 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node13);
+
+ procedure Set_Node14 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node14);
+
+ procedure Set_Node15 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node15);
+
+ procedure Set_Node16 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node16);
+
+ procedure Set_Node17 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node17);
+
+ procedure Set_Node18 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node18);
+
+ procedure Set_Node19 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node19);
+
+ procedure Set_Node20 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node20);
+
+ procedure Set_Node21 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node21);
+
+ procedure Set_Node22 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node22);
+
+ procedure Set_Node23 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node23);
+
+ procedure Set_List1 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List1);
+
+ procedure Set_List2 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List2);
+
+ procedure Set_List3 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List3);
+
+ procedure Set_List4 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List4);
+
+ procedure Set_List5 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List5);
+
+ procedure Set_List10 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List10);
+
+ procedure Set_List14 (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List14);
+
+ procedure Set_Elist2 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist2);
+
+ procedure Set_Elist3 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist3);
+
+ procedure Set_Elist4 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist4);
+
+ procedure Set_Elist8 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist8);
+
+ procedure Set_Elist13 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist13);
+
+ procedure Set_Elist15 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist15);
+
+ procedure Set_Elist16 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist16);
+
+ procedure Set_Elist18 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist18);
+
+ procedure Set_Elist21 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist21);
+
+ procedure Set_Elist23 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist23);
+
+ procedure Set_Name1 (N : Node_Id; Val : Name_Id);
+ pragma Inline (Set_Name1);
+
+ procedure Set_Name2 (N : Node_Id; Val : Name_Id);
+ pragma Inline (Set_Name2);
+
+ procedure Set_Char_Code2 (N : Node_Id; Val : Char_Code);
+ pragma Inline (Set_Char_Code2);
+
+ procedure Set_Str3 (N : Node_Id; Val : String_Id);
+ pragma Inline (Set_Str3);
+
+ procedure Set_Uint3 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint3);
+
+ procedure Set_Uint4 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint4);
+
+ procedure Set_Uint5 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint5);
+
+ procedure Set_Uint8 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint8);
+
+ procedure Set_Uint9 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint9);
+
+ procedure Set_Uint10 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint10);
+
+ procedure Set_Uint11 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint11);
+
+ procedure Set_Uint12 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint12);
+
+ procedure Set_Uint13 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint13);
+
+ procedure Set_Uint14 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint14);
+
+ procedure Set_Uint15 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint15);
+
+ procedure Set_Uint16 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint16);
+
+ procedure Set_Uint17 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint17);
+
+ procedure Set_Uint22 (N : Node_Id; Val : Uint);
+ pragma Inline (Set_Uint22);
+
+ procedure Set_Ureal3 (N : Node_Id; Val : Ureal);
+ pragma Inline (Set_Ureal3);
+
+ procedure Set_Ureal18 (N : Node_Id; Val : Ureal);
+ pragma Inline (Set_Ureal18);
+
+ procedure Set_Ureal21 (N : Node_Id; Val : Ureal);
+ pragma Inline (Set_Ureal21);
+
+ procedure Set_Flag4 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag4);
+
+ procedure Set_Flag5 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag5);
+
+ procedure Set_Flag6 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag6);
+
+ procedure Set_Flag7 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag7);
+
+ procedure Set_Flag8 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag8);
+
+ procedure Set_Flag9 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag9);
+
+ procedure Set_Flag10 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag10);
+
+ procedure Set_Flag11 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag11);
+
+ procedure Set_Flag12 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag12);
+
+ procedure Set_Flag13 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag13);
+
+ procedure Set_Flag14 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag14);
+
+ procedure Set_Flag15 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag15);
+
+ procedure Set_Flag16 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag16);
+
+ procedure Set_Flag17 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag17);
+
+ procedure Set_Flag18 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag18);
+
+ procedure Set_Flag19 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag19);
+
+ procedure Set_Flag20 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag20);
+
+ procedure Set_Flag21 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag21);
+
+ procedure Set_Flag22 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag22);
+
+ procedure Set_Flag23 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag23);
+
+ procedure Set_Flag24 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag24);
+
+ procedure Set_Flag25 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag25);
+
+ procedure Set_Flag26 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag26);
+
+ procedure Set_Flag27 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag27);
+
+ procedure Set_Flag28 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag28);
+
+ procedure Set_Flag29 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag29);
+
+ procedure Set_Flag30 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag30);
+
+ procedure Set_Flag31 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag31);
+
+ procedure Set_Flag32 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag32);
+
+ procedure Set_Flag33 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag33);
+
+ procedure Set_Flag34 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag34);
+
+ procedure Set_Flag35 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag35);
+
+ procedure Set_Flag36 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag36);
+
+ procedure Set_Flag37 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag37);
+
+ procedure Set_Flag38 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag38);
+
+ procedure Set_Flag39 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag39);
+
+ procedure Set_Flag40 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag40);
+
+ procedure Set_Flag41 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag41);
+
+ procedure Set_Flag42 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag42);
+
+ procedure Set_Flag43 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag43);
+
+ procedure Set_Flag44 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag44);
+
+ procedure Set_Flag45 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag45);
+
+ procedure Set_Flag46 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag46);
+
+ procedure Set_Flag47 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag47);
+
+ procedure Set_Flag48 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag48);
+
+ procedure Set_Flag49 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag49);
+
+ procedure Set_Flag50 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag50);
+
+ procedure Set_Flag51 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag51);
+
+ procedure Set_Flag52 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag52);
+
+ procedure Set_Flag53 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag53);
+
+ procedure Set_Flag54 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag54);
+
+ procedure Set_Flag55 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag55);
+
+ procedure Set_Flag56 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag56);
+
+ procedure Set_Flag57 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag57);
+
+ procedure Set_Flag58 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag58);
+
+ procedure Set_Flag59 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag59);
+
+ procedure Set_Flag60 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag60);
+
+ procedure Set_Flag61 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag61);
+
+ procedure Set_Flag62 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag62);
+
+ procedure Set_Flag63 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag63);
+
+ procedure Set_Flag64 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag64);
+
+ procedure Set_Flag65 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag65);
+
+ procedure Set_Flag66 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag66);
+
+ procedure Set_Flag67 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag67);
+
+ procedure Set_Flag68 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag68);
+
+ procedure Set_Flag69 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag69);
+
+ procedure Set_Flag70 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag70);
+
+ procedure Set_Flag71 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag71);
+
+ procedure Set_Flag72 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag72);
+
+ procedure Set_Flag73 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag73);
+
+ procedure Set_Flag74 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag74);
+
+ procedure Set_Flag75 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag75);
+
+ procedure Set_Flag76 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag76);
+
+ procedure Set_Flag77 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag77);
+
+ procedure Set_Flag78 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag78);
+
+ procedure Set_Flag79 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag79);
+
+ procedure Set_Flag80 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag80);
+
+ procedure Set_Flag81 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag81);
+
+ procedure Set_Flag82 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag82);
+
+ procedure Set_Flag83 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag83);
+
+ procedure Set_Flag84 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag84);
+
+ procedure Set_Flag85 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag85);
+
+ procedure Set_Flag86 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag86);
+
+ procedure Set_Flag87 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag87);
+
+ procedure Set_Flag88 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag88);
+
+ procedure Set_Flag89 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag89);
+
+ procedure Set_Flag90 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag90);
+
+ procedure Set_Flag91 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag91);
+
+ procedure Set_Flag92 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag92);
+
+ procedure Set_Flag93 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag93);
+
+ procedure Set_Flag94 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag94);
+
+ procedure Set_Flag95 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag95);
+
+ procedure Set_Flag96 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag96);
+
+ procedure Set_Flag97 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag97);
+
+ procedure Set_Flag98 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag98);
+
+ procedure Set_Flag99 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag99);
+
+ procedure Set_Flag100 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag100);
+
+ procedure Set_Flag101 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag101);
+
+ procedure Set_Flag102 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag102);
+
+ procedure Set_Flag103 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag103);
+
+ procedure Set_Flag104 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag104);
+
+ procedure Set_Flag105 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag105);
+
+ procedure Set_Flag106 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag106);
+
+ procedure Set_Flag107 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag107);
+
+ procedure Set_Flag108 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag108);
+
+ procedure Set_Flag109 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag109);
+
+ procedure Set_Flag110 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag110);
+
+ procedure Set_Flag111 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag111);
+
+ procedure Set_Flag112 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag112);
+
+ procedure Set_Flag113 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag113);
+
+ procedure Set_Flag114 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag114);
+
+ procedure Set_Flag115 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag115);
+
+ procedure Set_Flag116 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag116);
+
+ procedure Set_Flag117 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag117);
+
+ procedure Set_Flag118 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag118);
+
+ procedure Set_Flag119 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag119);
+
+ procedure Set_Flag120 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag120);
+
+ procedure Set_Flag121 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag121);
+
+ procedure Set_Flag122 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag122);
+
+ procedure Set_Flag123 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag123);
+
+ procedure Set_Flag124 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag124);
+
+ procedure Set_Flag125 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag125);
+
+ procedure Set_Flag126 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag126);
+
+ procedure Set_Flag127 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag127);
+
+ procedure Set_Flag128 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag128);
+
+ procedure Set_Flag129 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag129);
+
+ procedure Set_Flag130 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag130);
+
+ procedure Set_Flag131 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag131);
+
+ procedure Set_Flag132 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag132);
+
+ procedure Set_Flag133 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag133);
+
+ procedure Set_Flag134 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag134);
+
+ procedure Set_Flag135 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag135);
+
+ procedure Set_Flag136 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag136);
+
+ procedure Set_Flag137 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag137);
+
+ procedure Set_Flag138 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag138);
+
+ procedure Set_Flag139 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag139);
+
+ procedure Set_Flag140 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag140);
+
+ procedure Set_Flag141 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag141);
+
+ procedure Set_Flag142 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag142);
+
+ procedure Set_Flag143 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag143);
+
+ procedure Set_Flag144 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag144);
+
+ procedure Set_Flag145 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag145);
+
+ procedure Set_Flag146 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag146);
+
+ procedure Set_Flag147 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag147);
+
+ procedure Set_Flag148 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag148);
+
+ procedure Set_Flag149 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag149);
+
+ procedure Set_Flag150 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag150);
+
+ procedure Set_Flag151 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag151);
+
+ procedure Set_Flag152 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag152);
+
+ procedure Set_Flag153 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag153);
+
+ procedure Set_Flag154 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag154);
+
+ procedure Set_Flag155 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag155);
+
+ procedure Set_Flag156 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag156);
+
+ procedure Set_Flag157 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag157);
+
+ procedure Set_Flag158 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag158);
+
+ procedure Set_Flag159 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag159);
+
+ procedure Set_Flag160 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag160);
+
+ procedure Set_Flag161 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag161);
+
+ procedure Set_Flag162 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag162);
+
+ procedure Set_Flag163 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag163);
+
+ procedure Set_Flag164 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag164);
+
+ procedure Set_Flag165 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag165);
+
+ procedure Set_Flag166 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag166);
+
+ procedure Set_Flag167 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag167);
+
+ procedure Set_Flag168 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag168);
+
+ procedure Set_Flag169 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag169);
+
+ procedure Set_Flag170 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag170);
+
+ procedure Set_Flag171 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag171);
+
+ procedure Set_Flag172 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag172);
+
+ procedure Set_Flag173 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag173);
+
+ procedure Set_Flag174 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag174);
+
+ procedure Set_Flag175 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag175);
+
+ procedure Set_Flag176 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag176);
+
+ procedure Set_Flag177 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag177);
+
+ procedure Set_Flag178 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag178);
+
+ procedure Set_Flag179 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag179);
+
+ procedure Set_Flag180 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag180);
+
+ procedure Set_Flag181 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag181);
+
+ procedure Set_Flag182 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag182);
+
+ procedure Set_Flag183 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag183);
+
+ -- The following versions of Set_Noden also set the parent
+ -- pointer of the referenced node if it is non_Empty
+
+ procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node1_With_Parent);
+
+ procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node2_With_Parent);
+
+ procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node3_With_Parent);
+
+ procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node4_With_Parent);
+
+ procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node5_With_Parent);
+
+ -- The following versions of Set_Listn also set the parent pointer of
+ -- the referenced node if it is non_Empty. The procedures for List6
+ -- to List12 can only be applied to nodes which have an extension.
+
+ procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List1_With_Parent);
+
+ procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List2_With_Parent);
+
+ procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List3_With_Parent);
+
+ procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List4_With_Parent);
+
+ procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id);
+ pragma Inline (Set_List5_With_Parent);
+
+ end Unchecked_Access;
+
+ -----------------------------
+ -- Private Part Subpackage --
+ -----------------------------
+
+ -- The following package contains the definition of the data structure
+ -- used by the implementation of the Atree package. Logically it really
+ -- corresponds to the private part, hence the name. The reason that it
+ -- is defined as a sub-package is to allow special access from clients
+ -- that need to see the internals of the data structures.
+
+ package Atree_Private_Part is
+
+ -------------------------
+ -- Tree Representation --
+ -------------------------
+
+ -- The nodes of the tree are stored in a table (i.e. an array). In the
+ -- case of extended nodes four consecutive components in the array are
+ -- used. There are thus two formats for array components. One is used
+ -- for non-extended nodes, and for the first component of extended
+ -- nodes. The other is used for the extension parts (second, third and
+ -- fourth components) of an extended node. A variant record structure
+ -- is used to distinguish the two formats.
+
+ type Node_Record (Is_Extension : Boolean := False) is record
+
+ -- Logically, the only field in the common part is the above
+ -- Is_Extension discriminant (a single bit). However, Gigi cannot
+ -- yet handle such a structure, so we fill out the common part of
+ -- the record with fields that are used in different ways for
+ -- normal nodes and node extensions.
+
+ Pflag1, Pflag2 : Boolean;
+ -- The Paren_Count field is represented using two boolean flags,
+ -- where Pflag1 is worth 1, and Pflag2 is worth 2. This is done
+ -- because we need to be easily able to reuse this field for
+ -- extra flags in the extended node case.
+
+ In_List : Boolean;
+ -- Flag used to indicate if node is a member of a list.
+ -- This field is considered private to the Atree package.
+
+ Unused_1 : Boolean;
+ -- Currently unused flag
+
+ Rewrite_Ins : Boolean;
+ -- Flag set by Mark_Rewrite_Insertion procedure.
+ -- This field is considered private to the Atree package.
+
+ Analyzed : Boolean;
+ -- Flag to indicate the node has been analyzed (and expanded)
+
+ Comes_From_Source : Boolean;
+ -- Flag to indicate that node comes from the source program (i.e.
+ -- was built by the parser or scanner, not the analyzer or expander).
+
+ Error_Posted : Boolean;
+ -- Flag to indicate that an error message has been posted on the
+ -- node (to avoid duplicate flags on the same node)
+
+ Flag4 : Boolean;
+ Flag5 : Boolean;
+ Flag6 : Boolean;
+ Flag7 : Boolean;
+ Flag8 : Boolean;
+ Flag9 : Boolean;
+ Flag10 : Boolean;
+ Flag11 : Boolean;
+ Flag12 : Boolean;
+ Flag13 : Boolean;
+ Flag14 : Boolean;
+ Flag15 : Boolean;
+ Flag16 : Boolean;
+ Flag17 : Boolean;
+ Flag18 : Boolean;
+ -- The eighteen flags for a normal node
+
+ -- The above fields are used as follows in components 2-4 of
+ -- an extended node entry.
+
+ -- In_List used as Flag19, Flag40, Flag129
+ -- Unused_1 used as Flag20, Flag41, Flag130
+ -- Rewrite_Ins used as Flag21, Flag42, Flag131
+ -- Analyzed used as Flag22, Flag43, Flag132
+ -- Comes_From_Source used as Flag23, Flag44, Flag133
+ -- Error_Posted used as Flag24, Flag45, Flag134
+ -- Flag4 used as Flag25, Flag46, Flag135
+ -- Flag5 used as Flag26, Flag47, Flag136
+ -- Flag6 used as Flag27, Flag48, Flag137
+ -- Flag7 used as Flag28, Flag49, Flag138
+ -- Flag8 used as Flag29, Flag50, Flag139
+ -- Flag9 used as Flag30, Flag51, Flag140
+ -- Flag10 used as Flag31, Flag52, Flag141
+ -- Flag11 used as Flag32, Flag53, Flag142
+ -- Flag12 used as Flag33, Flag54, Flag143
+ -- Flag13 used as Flag34, Flag55, Flag144
+ -- Flag14 used as Flag35, Flag56, Flag145
+ -- Flag15 used as Flag36, Flag57, Flag146
+ -- Flag16 used as Flag37, Flag58, Flag147
+ -- Flag17 used as Flag38, Flag59, Flag148
+ -- Flag18 used as Flag39, Flag60, Flag149
+ -- Pflag1 used as Flag61, Flag62, Flag150
+ -- Pflag2 used as Flag63, Flag64, Flag151
+
+ Nkind : Node_Kind;
+ -- For a non-extended node, or the initial section of an extended
+ -- node, this field holds the Node_Kind value. For an extended node,
+ -- The Nkind field is used as follows:
+ --
+ -- Second entry: holds the Ekind field of the entity
+ -- Third entry: holds 8 additional flags (Flag65-Flag72)
+ -- Fourth entry: not currently used
+
+ -- Now finally (on an 32-bit boundary!) comes the variant part
+
+ case Is_Extension is
+
+ -- Non-extended node, or first component of extended node
+
+ when False =>
+
+ Sloc : Source_Ptr;
+ -- Source location for this node
+
+ Link : Union_Id;
+ -- This field is used either as the Parent pointer (if In_List
+ -- is False), or to point to the list header (if In_List is
+ -- True). This field is considered private and can be modified
+ -- only by Atree or by Nlists.
+
+ Field1 : Union_Id;
+ Field2 : Union_Id;
+ Field3 : Union_Id;
+ Field4 : Union_Id;
+ Field5 : Union_Id;
+ -- Five general use fields, which can contain Node_Id, List_Id,
+ -- Elist_Id, String_Id, Name_Id, or Char_Code values depending
+ -- on the values in Nkind and (for extended nodes), in Ekind.
+ -- See packages Sinfo and Einfo for details of their use.
+
+ -- Extension (second component) of extended node
+
+ when True =>
+ Field6 : Union_Id;
+ Field7 : Union_Id;
+ Field8 : Union_Id;
+ Field9 : Union_Id;
+ Field10 : Union_Id;
+ Field11 : Union_Id;
+ Field12 : Union_Id;
+ -- Seven additional general fields available only for entities
+ -- See package Einfo for details of their use (which depends
+ -- on the value in the Ekind field).
+
+ -- In the third component, the extension format as described
+ -- above is used to hold additional general fields and flags
+ -- as follows:
+
+ -- Field6-11 Holds Field13-Field18
+ -- Field12 Holds Flag73-Flag96 and Convention
+
+ -- In the fourth component, the extension format as described
+ -- above is used to hold additional general fields and flags
+ -- as follows:
+
+ -- Field6-10 Holds Field19-Field23
+ -- Field11 Holds Flag152-Flag167 (16 bits unused)
+ -- Field12 Holds Flag97-Flag128
+
+ end case;
+ end record;
+
+ pragma Pack (Node_Record);
+ for Node_Record'Size use 8*32;
+ for Node_Record'Alignment use 4;
+
+ -- The following defines the extendible array used for the nodes table
+ -- Nodes with extensions use two consecutive entries in the array
+
+ package Nodes is new Table.Table (
+ Table_Component_Type => Node_Record,
+ Table_Index_Type => Node_Id,
+ Table_Low_Bound => First_Node_Id,
+ Table_Initial => Alloc.Nodes_Initial,
+ Table_Increment => Alloc.Nodes_Increment,
+ Table_Name => "Nodes");
+
+ end Atree_Private_Part;
+
+end Atree;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * A T R E E *
+ * *
+ * C Header File *
+ * *
+ * $Revision: 1.1 $
+ * *
+ * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * 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 C header corresponding to the Ada package specification for
+ Atree. It also contains the implementations of inlined functions from the
+ package body for Tree. It was generated manually from atree.ads and
+ atree.adb and must be kept synchronized with changes in these files.
+
+ Note that only routines for reading the tree are included, since the tree
+ transformer is not supposed to modify the tree in any way. */
+
+/* Structure used for the first part of the node in the case where we have
+ an Nkind. */
+
+struct NFK
+{
+ Boolean is_extension : 1;
+ Boolean pflag1 : 1;
+ Boolean pflag2 : 1;
+ Boolean in_list : 1;
+ Boolean rewrite_sub : 1;
+ Boolean rewrite_ins : 1;
+ Boolean analyzed : 1;
+ Boolean comes_from_source : 1;
+
+ Boolean error_posted : 1;
+ Boolean flag4 : 1;
+ Boolean flag5 : 1;
+ Boolean flag6 : 1;
+ Boolean flag7 : 1;
+ Boolean flag8 : 1;
+ Boolean flag9 : 1;
+ Boolean flag10 : 1;
+
+ Boolean flag11 : 1;
+ Boolean flag12 : 1;
+ Boolean flag13 : 1;
+ Boolean flag14 : 1;
+ Boolean flag15 : 1;
+ Boolean flag16 : 1;
+ Boolean flag17 : 1;
+ Boolean flag18 : 1;
+
+ unsigned char kind;
+};
+
+/* Structure for the first part of a node when Nkind is not present by
+ extra flag bits are. */
+
+struct NFNK
+{
+ Boolean is_extension : 1;
+ Boolean pflag1 : 1;
+ Boolean pflag2 : 1;
+ Boolean in_list : 1;
+ Boolean rewrite_sub : 1;
+ Boolean rewrite_ins : 1;
+ Boolean analyzed : 1;
+ Boolean comes_from_source : 1;
+
+ Boolean error_posted : 1;
+ Boolean flag4 : 1;
+ Boolean flag5 : 1;
+ Boolean flag6 : 1;
+ Boolean flag7 : 1;
+ Boolean flag8 : 1;
+ Boolean flag9 : 1;
+ Boolean flag10 : 1;
+
+ Boolean flag11 : 1;
+ Boolean flag12 : 1;
+ Boolean flag13 : 1;
+ Boolean flag14 : 1;
+ Boolean flag15 : 1;
+ Boolean flag16 : 1;
+ Boolean flag17 : 1;
+ Boolean flag18 : 1;
+
+ Boolean flag65 : 1;
+ Boolean flag66 : 1;
+ Boolean flag67 : 1;
+ Boolean flag68 : 1;
+ Boolean flag69 : 1;
+ Boolean flag70 : 1;
+ Boolean flag71 : 1;
+ Boolean flag72 : 1;
+};
+
+/* Structure used for extra flags in third component overlaying Field12 */
+struct Flag_Word
+{
+ Boolean flag73 : 1;
+ Boolean flag74 : 1;
+ Boolean flag75 : 1;
+ Boolean flag76 : 1;
+ Boolean flag77 : 1;
+ Boolean flag78 : 1;
+ Boolean flag79 : 1;
+ Boolean flag80 : 1;
+ Boolean flag81 : 1;
+ Boolean flag82 : 1;
+ Boolean flag83 : 1;
+ Boolean flag84 : 1;
+ Boolean flag85 : 1;
+ Boolean flag86 : 1;
+ Boolean flag87 : 1;
+ Boolean flag88 : 1;
+ Boolean flag89 : 1;
+ Boolean flag90 : 1;
+ Boolean flag91 : 1;
+ Boolean flag92 : 1;
+ Boolean flag93 : 1;
+ Boolean flag94 : 1;
+ Boolean flag95 : 1;
+ Boolean flag96 : 1;
+ Short convention : 8;
+};
+
+/* Structure used for extra flags in fourth component overlaying Field12 */
+struct Flag_Word2
+{
+ Boolean flag97 : 1;
+ Boolean flag98 : 1;
+ Boolean flag99 : 1;
+ Boolean flag100 : 1;
+ Boolean flag101 : 1;
+ Boolean flag102 : 1;
+ Boolean flag103 : 1;
+ Boolean flag104 : 1;
+ Boolean flag105 : 1;
+ Boolean flag106 : 1;
+ Boolean flag107 : 1;
+ Boolean flag108 : 1;
+ Boolean flag109 : 1;
+ Boolean flag110 : 1;
+ Boolean flag111 : 1;
+ Boolean flag112 : 1;
+ Boolean flag113 : 1;
+ Boolean flag114 : 1;
+ Boolean flag115 : 1;
+ Boolean flag116 : 1;
+ Boolean flag117 : 1;
+ Boolean flag118 : 1;
+ Boolean flag119 : 1;
+ Boolean flag120 : 1;
+ Boolean flag121 : 1;
+ Boolean flag122 : 1;
+ Boolean flag123 : 1;
+ Boolean flag124 : 1;
+ Boolean flag125 : 1;
+ Boolean flag126 : 1;
+ Boolean flag127 : 1;
+ Boolean flag128 : 1;
+};
+
+/* Structure used for extra flags in fourth component overlaying Field11 */
+struct Flag_Word3
+{
+ Boolean flag152 : 1;
+ Boolean flag153 : 1;
+ Boolean flag154 : 1;
+ Boolean flag155 : 1;
+ Boolean flag156 : 1;
+ Boolean flag157 : 1;
+ Boolean flag158 : 1;
+ Boolean flag159 : 1;
+
+ Boolean flag160 : 1;
+ Boolean flag161 : 1;
+ Boolean flag162 : 1;
+ Boolean flag163 : 1;
+ Boolean flag164 : 1;
+ Boolean flag165 : 1;
+ Boolean flag166 : 1;
+ Boolean flag167 : 1;
+
+ Boolean flag168 : 1;
+ Boolean flag169 : 1;
+ Boolean flag170 : 1;
+ Boolean flag171 : 1;
+ Boolean flag172 : 1;
+ Boolean flag173 : 1;
+ Boolean flag174 : 1;
+ Boolean flag175 : 1;
+
+ Boolean flag176 : 1;
+ Boolean flag177 : 1;
+ Boolean flag178 : 1;
+ Boolean flag179 : 1;
+ Boolean flag180 : 1;
+ Boolean flag181 : 1;
+ Boolean flag182 : 1;
+ Boolean flag183 : 1;
+};
+
+struct Non_Extended
+{
+ Source_Ptr sloc;
+ Int link;
+ Int field1;
+ Int field2;
+ Int field3;
+ Int field4;
+ Int field5;
+};
+
+/* The Following structure corresponds to variant with is_extension = True. */
+struct Extended
+{
+ Int field6;
+ Int field7;
+ Int field8;
+ Int field9;
+ Int field10;
+ union
+ {
+ Int field11;
+ struct Flag_Word3 fw3;
+ } X;
+
+ union
+ {
+ Int field12;
+ struct Flag_Word fw;
+ struct Flag_Word2 fw2;
+ } U;
+};
+
+/* A tree node itself. */
+
+struct Node
+{
+ union kind
+ {
+ struct NFK K;
+ struct NFNK NK;
+ } U;
+
+ union variant
+ {
+ struct Non_Extended NX;
+ struct Extended EX;
+ } V;
+};
+
+/* The actual tree is an array of nodes. The pointer to this array is passed
+ as a parameter to the tree transformer procedure and stored in the global
+ variable Nodes_Ptr after adjusting it by subtracting Node_First_Entry, so
+ that Node_Id values can be used as subscripts. */
+extern struct Node *Nodes_Ptr;
+
+
+#define Parent atree__parent
+extern Node_Id Parent PARAMS((Node_Id));
+
+/* Overloaded Functions:
+
+ These functions are overloaded in the original Ada source, but there is
+ only one corresponding C function, which works as described below. */
+
+/* Type used for union of Node_Id, List_Id, Elist_Id. */
+typedef Int Tree_Id;
+
+/* These two functions can only be used for Node_Id and List_Id values and
+ they work in the C version because Empty = No_List = 0. */
+
+static Boolean No PARAMS ((Tree_Id));
+static Boolean Present PARAMS ((Tree_Id));
+
+INLINE Boolean
+No (N)
+ Tree_Id N;
+{
+ return N == Empty;
+}
+
+INLINE Boolean
+Present (N)
+ Tree_Id N;
+{
+ return N != Empty;
+}
+
+extern Node_Id Parent PARAMS((Tree_Id));
+
+#define Current_Error_Node atree__current_error_node
+extern Node_Id Current_Error_Node;
+
+/* Node Access Functions: */
+
+#define Nkind(N) ((Node_Kind)(Nodes_Ptr [N].U.K.kind))
+#define Ekind(N) ((Entity_Kind)(Nodes_Ptr [N + 1].U.K.kind))
+#define Sloc(N) (Nodes_Ptr [N].V.NX.sloc)
+#define Paren_Count(N) (Nodes_Ptr [N].U.K.pflag1 \
+ + 2 * Nodes_Ptr [N].U.K.pflag2)
+
+#define Field1(N) (Nodes_Ptr [N].V.NX.field1)
+#define Field2(N) (Nodes_Ptr [N].V.NX.field2)
+#define Field3(N) (Nodes_Ptr [N].V.NX.field3)
+#define Field4(N) (Nodes_Ptr [N].V.NX.field4)
+#define Field5(N) (Nodes_Ptr [N].V.NX.field5)
+#define Field6(N) (Nodes_Ptr [(N)+1].V.EX.field6)
+#define Field7(N) (Nodes_Ptr [(N)+1].V.EX.field7)
+#define Field8(N) (Nodes_Ptr [(N)+1].V.EX.field8)
+#define Field9(N) (Nodes_Ptr [(N)+1].V.EX.field9)
+#define Field10(N) (Nodes_Ptr [(N)+1].V.EX.field10)
+#define Field11(N) (Nodes_Ptr [(N)+1].V.EX.X.field11)
+#define Field12(N) (Nodes_Ptr [(N)+1].V.EX.U.field12)
+#define Field13(N) (Nodes_Ptr [(N)+2].V.EX.field6)
+#define Field14(N) (Nodes_Ptr [(N)+2].V.EX.field7)
+#define Field15(N) (Nodes_Ptr [(N)+2].V.EX.field8)
+#define Field16(N) (Nodes_Ptr [(N)+2].V.EX.field9)
+#define Field17(N) (Nodes_Ptr [(N)+2].V.EX.field10)
+#define Field18(N) (Nodes_Ptr [(N)+2].V.EX.X.field11)
+#define Field19(N) (Nodes_Ptr [(N)+3].V.EX.field6)
+#define Field20(N) (Nodes_Ptr [(N)+3].V.EX.field7)
+#define Field21(N) (Nodes_Ptr [(N)+3].V.EX.field8)
+#define Field22(N) (Nodes_Ptr [(N)+3].V.EX.field9)
+#define Field23(N) (Nodes_Ptr [(N)+3].V.EX.field10)
+
+#define Node1(N) Field1 (N)
+#define Node2(N) Field2 (N)
+#define Node3(N) Field3 (N)
+#define Node4(N) Field4 (N)
+#define Node5(N) Field5 (N)
+#define Node6(N) Field6 (N)
+#define Node7(N) Field7 (N)
+#define Node8(N) Field8 (N)
+#define Node9(N) Field9 (N)
+#define Node10(N) Field10 (N)
+#define Node11(N) Field11 (N)
+#define Node12(N) Field12 (N)
+#define Node13(N) Field13 (N)
+#define Node14(N) Field14 (N)
+#define Node15(N) Field15 (N)
+#define Node16(N) Field16 (N)
+#define Node17(N) Field17 (N)
+#define Node18(N) Field18 (N)
+#define Node19(N) Field19 (N)
+#define Node20(N) Field20 (N)
+#define Node21(N) Field21 (N)
+#define Node22(N) Field22 (N)
+#define Node23(N) Field23 (N)
+
+#define List1(N) Field1 (N)
+#define List2(N) Field2 (N)
+#define List3(N) Field3 (N)
+#define List4(N) Field4 (N)
+#define List5(N) Field5 (N)
+#define List10(N) Field10 (N)
+#define List14(N) Field14 (N)
+
+#define Elist2(N) Field2 (N)
+#define Elist3(N) Field3 (N)
+#define Elist4(N) Field4 (N)
+#define Elist8(N) Field8 (N)
+#define Elist13(N) Field13 (N)
+#define Elist15(N) Field15 (N)
+#define Elist18(N) Field18 (N)
+#define Elist21(N) Field21 (N)
+#define Elist23(N) Field23 (N)
+
+#define Name1(N) Field1 (N)
+#define Name2(N) Field2 (N)
+
+#define Char_Code2(N) (Field2 (N) - Char_Code_Bias)
+
+#define Str3(N) Field3 (N)
+
+#define Uint3(N) ((Field3 (N)==0) ? Uint_0 : Field3 (N))
+#define Uint4(N) ((Field4 (N)==0) ? Uint_0 : Field4 (N))
+#define Uint5(N) ((Field5 (N)==0) ? Uint_0 : Field5 (N))
+#define Uint8(N) ((Field8 (N)==0) ? Uint_0 : Field8 (N))
+#define Uint9(N) ((Field9 (N)==0) ? Uint_0 : Field9 (N))
+#define Uint10(N) ((Field10 (N)==0) ? Uint_0 : Field10 (N))
+#define Uint11(N) ((Field11 (N)==0) ? Uint_0 : Field11 (N))
+#define Uint12(N) ((Field12 (N)==0) ? Uint_0 : Field12 (N))
+#define Uint13(N) ((Field13 (N)==0) ? Uint_0 : Field13 (N))
+#define Uint14(N) ((Field14 (N)==0) ? Uint_0 : Field14 (N))
+#define Uint15(N) ((Field15 (N)==0) ? Uint_0 : Field15 (N))
+#define Uint16(N) ((Field16 (N)==0) ? Uint_0 : Field16 (N))
+#define Uint17(N) ((Field17 (N)==0) ? Uint_0 : Field17 (N))
+#define Uint22(N) ((Field22 (N)==0) ? Uint_0 : Field22 (N))
+
+#define Ureal3(N) Field3 (N)
+#define Ureal18(N) Field18 (N)
+#define Ureal21(N) Field21 (N)
+
+#define Analyzed(N) (Nodes_Ptr [N].U.K.analyzed)
+#define Comes_From_Source(N) (Nodes_Ptr [N].U.K.comes_from_source)
+#define Error_Posted(N) (Nodes_Ptr [N].U.K.error_posted)
+
+#define Flag4(N) (Nodes_Ptr [N].U.K.flag4)
+#define Flag5(N) (Nodes_Ptr [N].U.K.flag5)
+#define Flag6(N) (Nodes_Ptr [N].U.K.flag6)
+#define Flag7(N) (Nodes_Ptr [N].U.K.flag7)
+#define Flag8(N) (Nodes_Ptr [N].U.K.flag8)
+#define Flag9(N) (Nodes_Ptr [N].U.K.flag9)
+#define Flag10(N) (Nodes_Ptr [N].U.K.flag10)
+#define Flag11(N) (Nodes_Ptr [N].U.K.flag11)
+#define Flag12(N) (Nodes_Ptr [N].U.K.flag12)
+#define Flag13(N) (Nodes_Ptr [N].U.K.flag13)
+#define Flag14(N) (Nodes_Ptr [N].U.K.flag14)
+#define Flag15(N) (Nodes_Ptr [N].U.K.flag15)
+#define Flag16(N) (Nodes_Ptr [N].U.K.flag16)
+#define Flag17(N) (Nodes_Ptr [N].U.K.flag17)
+#define Flag18(N) (Nodes_Ptr [N].U.K.flag18)
+
+#define Flag19(N) (Nodes_Ptr [(N)+1].U.K.in_list)
+#define Flag20(N) (Nodes_Ptr [(N)+1].U.K.rewrite_sub)
+#define Flag21(N) (Nodes_Ptr [(N)+1].U.K.rewrite_ins)
+#define Flag22(N) (Nodes_Ptr [(N)+1].U.K.analyzed)
+#define Flag23(N) (Nodes_Ptr [(N)+1].U.K.comes_from_source)
+#define Flag24(N) (Nodes_Ptr [(N)+1].U.K.error_posted)
+#define Flag25(N) (Nodes_Ptr [(N)+1].U.K.flag4)
+#define Flag26(N) (Nodes_Ptr [(N)+1].U.K.flag5)
+#define Flag27(N) (Nodes_Ptr [(N)+1].U.K.flag6)
+#define Flag28(N) (Nodes_Ptr [(N)+1].U.K.flag7)
+#define Flag29(N) (Nodes_Ptr [(N)+1].U.K.flag8)
+#define Flag30(N) (Nodes_Ptr [(N)+1].U.K.flag9)
+#define Flag31(N) (Nodes_Ptr [(N)+1].U.K.flag10)
+#define Flag32(N) (Nodes_Ptr [(N)+1].U.K.flag11)
+#define Flag33(N) (Nodes_Ptr [(N)+1].U.K.flag12)
+#define Flag34(N) (Nodes_Ptr [(N)+1].U.K.flag13)
+#define Flag35(N) (Nodes_Ptr [(N)+1].U.K.flag14)
+#define Flag36(N) (Nodes_Ptr [(N)+1].U.K.flag15)
+#define Flag37(N) (Nodes_Ptr [(N)+1].U.K.flag16)
+#define Flag38(N) (Nodes_Ptr [(N)+1].U.K.flag17)
+#define Flag39(N) (Nodes_Ptr [(N)+1].U.K.flag18)
+
+#define Flag40(N) (Nodes_Ptr [(N)+2].U.K.in_list)
+#define Flag41(N) (Nodes_Ptr [(N)+2].U.K.rewrite_sub)
+#define Flag42(N) (Nodes_Ptr [(N)+2].U.K.rewrite_ins)
+#define Flag43(N) (Nodes_Ptr [(N)+2].U.K.analyzed)
+#define Flag44(N) (Nodes_Ptr [(N)+2].U.K.comes_from_source)
+#define Flag45(N) (Nodes_Ptr [(N)+2].U.K.error_posted)
+#define Flag46(N) (Nodes_Ptr [(N)+2].U.K.flag4)
+#define Flag47(N) (Nodes_Ptr [(N)+2].U.K.flag5)
+#define Flag48(N) (Nodes_Ptr [(N)+2].U.K.flag6)
+#define Flag49(N) (Nodes_Ptr [(N)+2].U.K.flag7)
+#define Flag50(N) (Nodes_Ptr [(N)+2].U.K.flag8)
+#define Flag51(N) (Nodes_Ptr [(N)+2].U.K.flag9)
+#define Flag52(N) (Nodes_Ptr [(N)+2].U.K.flag10)
+#define Flag53(N) (Nodes_Ptr [(N)+2].U.K.flag11)
+#define Flag54(N) (Nodes_Ptr [(N)+2].U.K.flag12)
+#define Flag55(N) (Nodes_Ptr [(N)+2].U.K.flag13)
+#define Flag56(N) (Nodes_Ptr [(N)+2].U.K.flag14)
+#define Flag57(N) (Nodes_Ptr [(N)+2].U.K.flag15)
+#define Flag58(N) (Nodes_Ptr [(N)+2].U.K.flag16)
+#define Flag59(N) (Nodes_Ptr [(N)+2].U.K.flag17)
+#define Flag60(N) (Nodes_Ptr [(N)+2].U.K.flag18)
+#define Flag61(N) (Nodes_Ptr [(N)+1].U.K.pflag1)
+#define Flag62(N) (Nodes_Ptr [(N)+1].U.K.pflag2)
+#define Flag63(N) (Nodes_Ptr [(N)+2].U.K.pflag1)
+#define Flag64(N) (Nodes_Ptr [(N)+2].U.K.pflag2)
+
+#define Flag65(N) (Nodes_Ptr [(N)+2].U.NK.flag65)
+#define Flag66(N) (Nodes_Ptr [(N)+2].U.NK.flag66)
+#define Flag67(N) (Nodes_Ptr [(N)+2].U.NK.flag67)
+#define Flag68(N) (Nodes_Ptr [(N)+2].U.NK.flag68)
+#define Flag69(N) (Nodes_Ptr [(N)+2].U.NK.flag69)
+#define Flag70(N) (Nodes_Ptr [(N)+2].U.NK.flag70)
+#define Flag71(N) (Nodes_Ptr [(N)+2].U.NK.flag71)
+#define Flag72(N) (Nodes_Ptr [(N)+2].U.NK.flag72)
+
+#define Flag73(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag73)
+#define Flag74(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag74)
+#define Flag75(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag75)
+#define Flag76(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag76)
+#define Flag77(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag77)
+#define Flag78(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag78)
+#define Flag79(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag79)
+#define Flag80(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag80)
+#define Flag81(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag81)
+#define Flag82(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag82)
+#define Flag83(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag83)
+#define Flag84(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag84)
+#define Flag85(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag85)
+#define Flag86(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag86)
+#define Flag87(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag87)
+#define Flag88(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag88)
+#define Flag89(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag89)
+#define Flag90(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag90)
+#define Flag91(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag91)
+#define Flag92(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag92)
+#define Flag93(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag93)
+#define Flag94(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag94)
+#define Flag95(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag95)
+#define Flag96(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag96)
+
+#define Convention(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.convention)
+
+#define Flag97(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag97)
+#define Flag98(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag98)
+#define Flag99(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag99)
+#define Flag100(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag100)
+#define Flag101(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag101)
+#define Flag102(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag102)
+#define Flag103(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag103)
+#define Flag104(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag104)
+#define Flag105(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag105)
+#define Flag106(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag106)
+#define Flag107(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag107)
+#define Flag108(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag108)
+#define Flag109(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag109)
+#define Flag110(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag110)
+#define Flag111(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag111)
+#define Flag112(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag112)
+#define Flag113(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag113)
+#define Flag114(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag114)
+#define Flag115(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag115)
+#define Flag116(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag116)
+#define Flag117(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag117)
+#define Flag118(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag118)
+#define Flag119(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag119)
+#define Flag120(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag120)
+#define Flag121(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag121)
+#define Flag122(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag122)
+#define Flag123(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag123)
+#define Flag124(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag124)
+#define Flag125(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag125)
+#define Flag126(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag126)
+#define Flag127(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag127)
+#define Flag128(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag128)
+
+#define Flag129(N) (Nodes_Ptr [(N)+3].U.K.in_list)
+#define Flag130(N) (Nodes_Ptr [(N)+3].U.K.rewrite_sub)
+#define Flag131(N) (Nodes_Ptr [(N)+3].U.K.rewrite_ins)
+#define Flag132(N) (Nodes_Ptr [(N)+3].U.K.analyzed)
+#define Flag133(N) (Nodes_Ptr [(N)+3].U.K.comes_from_source)
+#define Flag134(N) (Nodes_Ptr [(N)+3].U.K.error_posted)
+#define Flag135(N) (Nodes_Ptr [(N)+3].U.K.flag4)
+#define Flag136(N) (Nodes_Ptr [(N)+3].U.K.flag5)
+#define Flag137(N) (Nodes_Ptr [(N)+3].U.K.flag6)
+#define Flag138(N) (Nodes_Ptr [(N)+3].U.K.flag7)
+#define Flag139(N) (Nodes_Ptr [(N)+3].U.K.flag8)
+#define Flag140(N) (Nodes_Ptr [(N)+3].U.K.flag9)
+#define Flag141(N) (Nodes_Ptr [(N)+3].U.K.flag10)
+#define Flag142(N) (Nodes_Ptr [(N)+3].U.K.flag11)
+#define Flag143(N) (Nodes_Ptr [(N)+3].U.K.flag12)
+#define Flag144(N) (Nodes_Ptr [(N)+3].U.K.flag13)
+#define Flag145(N) (Nodes_Ptr [(N)+3].U.K.flag14)
+#define Flag146(N) (Nodes_Ptr [(N)+3].U.K.flag15)
+#define Flag147(N) (Nodes_Ptr [(N)+3].U.K.flag16)
+#define Flag148(N) (Nodes_Ptr [(N)+3].U.K.flag17)
+#define Flag149(N) (Nodes_Ptr [(N)+3].U.K.flag18)
+#define Flag150(N) (Nodes_Ptr [(N)+3].U.K.pflag1)
+#define Flag151(N) (Nodes_Ptr [(N)+3].U.K.pflag2)
+
+#define Flag152(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag152)
+#define Flag153(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag153)
+#define Flag154(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag154)
+#define Flag155(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag155)
+#define Flag156(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag156)
+#define Flag157(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag157)
+#define Flag158(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag158)
+#define Flag159(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag159)
+#define Flag160(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag160)
+#define Flag161(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag161)
+#define Flag162(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag162)
+#define Flag163(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag163)
+#define Flag164(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag164)
+#define Flag165(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag165)
+#define Flag166(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag166)
+#define Flag167(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag167)
+#define Flag168(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag168)
+#define Flag169(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag169)
+#define Flag170(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag170)
+#define Flag171(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag171)
+#define Flag172(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag172)
+#define Flag173(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag173)
+#define Flag174(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag174)
+#define Flag175(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag175)
+#define Flag176(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag176)
+#define Flag177(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag177)
+#define Flag178(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag178)
+#define Flag179(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag179)
+#define Flag180(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag180)
+#define Flag181(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag181)
+#define Flag182(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag182)
+#define Flag183(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag183)
projects / thirdparty / gcc.git / commitdiff
