diff options
| author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 09:55:47 -0400 |
|---|---|---|
| committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 09:55:47 -0400 |
| commit | d23b8f573b3dcbfc04d13387885059de809aec50 (patch) | |
| tree | 2984031fa75d4e716ac1f562efe5ae818a291ca8 /gcc | |
| parent | 84481f762f0682e5f45b2f360446e1c7e333c880 (diff) | |
| download | gcc-d23b8f573b3dcbfc04d13387885059de809aec50.tar.gz | |
New Language: Ada
From-SVN: r45953
Diffstat (limited to 'gcc')
225 files changed, 63455 insertions, 0 deletions
diff --git a/gcc/ada/a-astaco.adb b/gcc/ada/a-astaco.adb new file mode 100644 index 00000000000..7e9ca52d757 --- /dev/null +++ b/gcc/ada/a-astaco.adb @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy body, which will not normally be compiled when used with +-- standard versions of GNAT, which do not support this package. See comments +-- in spec for further details. + +package body Ada.Asynchronous_Task_Control is + + -------------- + -- Continue -- + -------------- + + procedure Continue (T : Ada.Task_Identification.Task_Id) is + begin + null; + end Continue; + + ---------- + -- Hold -- + ---------- + + procedure Hold (T : Ada.Task_Identification.Task_Id) is + begin + raise Program_Error; + end Hold; + + ------------- + -- Is_Held -- + ------------- + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean is + begin + return False; + end Is_Held; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-astaco.ads b/gcc/ada/a-astaco.ads new file mode 100644 index 00000000000..fe405735730 --- /dev/null +++ b/gcc/ada/a-astaco.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + + -- This unit is not implemented in typical GNAT implementations that + -- lie on top of operating systems, because it is infeasible to implement + -- in such environments. The RM anticipates this situation (RM D.11(10)), + -- and permits an implementation to leave this unimplemented even if the + -- Real-Time Systems annex is fully supported. + + -- If a target environment provides appropriate support for this package, + -- then the Unimplemented_Unit pragma should be removed from this spec, + -- and an appropriate body provided. The framework for such a body is + -- included in the distributed sources. + +with Ada.Task_Identification; + +package Ada.Asynchronous_Task_Control is + + pragma Unimplemented_Unit; + + procedure Hold (T : Ada.Task_Identification.Task_Id); + + procedure Continue (T : Ada.Task_Identification.Task_Id); + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb new file mode 100644 index 00000000000..bada6b4c7bc --- /dev/null +++ b/gcc/ada/a-caldel.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.37 $ +-- -- +-- Copyright (C) 1991-2001 Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Primitives; +-- Used for Delay_Modes +-- Max_Sensible_Delay + +with System.Soft_Links; +-- Used for Timed_Delay + +package body Ada.Calendar.Delays is + + package OSP renames System.OS_Primitives; + package SSL renames System.Soft_Links; + + use type SSL.Timed_Delay_Call; + + -- Earlier, the following operations were implemented using + -- System.Time_Operations. The idea was to avoid sucking in the tasking + -- packages. This did not work. Logically, we can't have it both ways. + -- There is no way to implement time delays that will have correct task + -- semantics without reference to the tasking run-time system. + -- To achieve this goal, we now use soft links. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer); + -- Timed delay procedure used when no tasking is active + + --------------- + -- Delay_For -- + --------------- + + procedure Delay_For (D : Duration) is + begin + SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), + OSP.Relative); + end Delay_For; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + begin + SSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); + end Delay_Until; + + -------------------- + -- Timed_Delay_NT -- + -------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is + begin + OSP.Timed_Delay (Time, Mode); + end Timed_Delay_NT; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + begin + return Duration (T); + end To_Duration; + +begin + -- Set up the Timed_Delay soft link to the non tasking version + -- if it has not been already set. + + -- If tasking is present, Timed_Delay has already set this soft + -- link, or this will be overriden during the elaboration of + -- System.Tasking.Initialization + + if SSL.Timed_Delay = null then + SSL.Timed_Delay := Timed_Delay_NT'Access; + end if; +end Ada.Calendar.Delays; diff --git a/gcc/ada/a-caldel.ads b/gcc/ada/a-caldel.ads new file mode 100644 index 00000000000..3220bc160dc --- /dev/null +++ b/gcc/ada/a-caldel.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.16 $ -- +-- -- +-- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements Calendar.Time delays using protected objects. + +-- Note: the compiler generates direct calls to this interface, in the +-- processing of time types. + +package Ada.Calendar.Delays is + + procedure Delay_For (D : Duration); + -- Delay until an interval of length (at least) D seconds has passed, + -- or the task is aborted to at least the current ATC nesting level. + -- This is an abort completion point. + -- The body of this procedure must perform all the processing + -- required for an abortion point. + + procedure Delay_Until (T : Time); + -- Delay until Clock has reached (at least) time T, + -- or the task is aborted to at least the current ATC nesting level. + -- The body of this procedure must perform all the processing + -- required for an abortion point. + + function To_Duration (T : Time) return Duration; + +end Ada.Calendar.Delays; diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb new file mode 100644 index 00000000000..17f3463161a --- /dev/null +++ b/gcc/ada/a-calend.adb @@ -0,0 +1,490 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.51 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Conversion; + +with System.OS_Primitives; +-- used for Clock + +package body Ada.Calendar is + + ------------------------------ + -- Use of Pragma Unsuppress -- + ------------------------------ + + -- This implementation of Calendar takes advantage of the permission in + -- Ada 95 of using arithmetic overflow checks to check for out of bounds + -- time values. This means that we must catch the constraint error that + -- results from arithmetic overflow, so we use pragma Unsuppress to make + -- sure that overflow is enabled, using software overflow checking if + -- necessary. That way, compiling Calendar with options to suppress this + -- checking will not affect its correctness. + + ------------------------ + -- Local Declarations -- + ------------------------ + + type Char_Pointer is access Character; + subtype int is Integer; + subtype long is Long_Integer; + -- Synonyms for C types. We don't want to get them from Interfaces.C + -- because there is no point in loading that unit just for calendar. + + type tm is record + tm_sec : int; -- seconds after the minute (0 .. 60) + tm_min : int; -- minutes after the hour (0 .. 59) + tm_hour : int; -- hours since midnight (0 .. 24) + tm_mday : int; -- day of the month (1 .. 31) + tm_mon : int; -- months since January (0 .. 11) + tm_year : int; -- years since 1900 + tm_wday : int; -- days since Sunday (0 .. 6) + tm_yday : int; -- days since January 1 (0 .. 365) + tm_isdst : int; -- Daylight Savings Time flag (-1 .. +1) + tm_gmtoff : long; -- offset from CUT in seconds + tm_zone : Char_Pointer; -- timezone abbreviation + end record; + + type tm_Pointer is access all tm; + + subtype time_t is long; + + type time_t_Pointer is access all time_t; + + procedure localtime_r (C : time_t_Pointer; res : tm_Pointer); + pragma Import (C, localtime_r, "__gnat_localtime_r"); + + function mktime (TM : tm_Pointer) return time_t; + pragma Import (C, mktime); + -- mktime returns -1 in case the calendar time given by components of + -- TM.all cannot be represented. + + -- The following constants are used in adjusting Ada dates so that they + -- fit into the range that can be handled by Unix (1970 - 2038). The trick + -- is that the number of days in any four year period in the Ada range of + -- years (1901 - 2099) has a constant number of days. This is because we + -- have the special case of 2000 which, contrary to the normal exception + -- for centuries, is a leap year after all. + + Unix_Year_Min : constant := 1970; + Unix_Year_Max : constant := 2038; + + Ada_Year_Min : constant := 1901; + Ada_Year_Max : constant := 2099; + + -- Some basic constants used throughout + + Days_In_Month : constant array (Month_Number) of Day_Number := + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + + Days_In_4_Years : constant := 365 * 3 + 366; + Seconds_In_4_Years : constant := 86_400 * Days_In_4_Years; + Seconds_In_4_YearsD : constant Duration := Duration (Seconds_In_4_Years); + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (Left + Time (Right)); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (Time (Left) + Right); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left - Time (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + begin + return Duration (Left) - Duration (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return Duration (Left) < Duration (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return Duration (Left) <= Duration (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return Duration (Left) > Duration (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return Duration (Left) >= Duration (Right); + end ">="; + + ----------- + -- Clock -- + ----------- + + function Clock return Time is + begin + return Time (System.OS_Primitives.Clock); + end Clock; + + --------- + -- Day -- + --------- + + function Day (Date : Time) return Day_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DD; + end Day; + + ----------- + -- Month -- + ----------- + + function Month (Date : Time) return Month_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DM; + end Month; + + ------------- + -- Seconds -- + ------------- + + function Seconds (Date : Time) return Day_Duration is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DS; + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration) + is + -- The following declare bounds for duration that are comfortably + -- wider than the maximum allowed output result for the Ada range + -- of representable split values. These are used for a quick check + -- that the value is not wildly out of range. + + Low : constant := (Ada_Year_Min - Unix_Year_Min - 2) * 365 * 86_400; + High : constant := (Ada_Year_Max - Unix_Year_Min + 2) * 365 * 86_400; + + LowD : constant Duration := Duration (Low); + HighD : constant Duration := Duration (High); + + -- The following declare the maximum duration value that can be + -- successfully converted to a 32-bit integer suitable for passing + -- to the localtime_r function. Note that we cannot assume that the + -- localtime_r function expands to accept 64-bit input on a 64-bit + -- machine, but we can count on a 32-bit range on all machines. + + Max_Time : constant := 2 ** 31 - 1; + Max_TimeD : constant Duration := Duration (Max_Time); + + -- Finally the actual variables used in the computation + + D : Duration; + Frac_Sec : Duration; + Year_Val : Integer; + Adjusted_Seconds : aliased time_t; + Tm_Val : aliased tm; + + begin + -- For us a time is simply a signed duration value, so we work with + -- this duration value directly. Note that it can be negative. + + D := Duration (Date); + + -- First of all, filter out completely ludicrous values. Remember + -- that we use the full stored range of duration values, which may + -- be significantly larger than the allowed range of Ada times. Note + -- that these checks are wider than required to make absolutely sure + -- that there are no end effects from time zone differences. + + if D < LowD or else D > HighD then + raise Time_Error; + end if; + + -- The unix localtime_r function is more or less exactly what we need + -- here. The less comes from the fact that it does not support the + -- required range of years (the guaranteed range available is only + -- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1. + + -- If we have a value outside this range, then we first adjust it + -- to be in the required range by adding multiples of four years. + -- For the range we are interested in, the number of days in any + -- consecutive four year period is constant. Then we do the split + -- on the adjusted value, and readjust the years value accordingly. + + Year_Val := 0; + + while D < 0.0 loop + D := D + Seconds_In_4_YearsD; + Year_Val := Year_Val - 4; + end loop; + + while D > Max_TimeD loop + D := D - Seconds_In_4_YearsD; + Year_Val := Year_Val + 4; + end loop; + + -- Now we need to take the value D, which is now non-negative, and + -- break it down into seconds (to pass to the localtime_r function) + -- and fractions of seconds (for the adjustment below). + + -- Surprisingly there is no easy way to do this in Ada, and certainly + -- no easy way to do it and generate efficient code. Therefore we + -- do it at a low level, knowing that it is really represented as + -- an integer with units of Small + + declare + type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1; + for D_Int'Size use Duration'Size; + + Small_Div : constant D_Int := D_Int (1.0 / Duration'Small); + D_As_Int : D_Int; + + function To_D_As_Int is new Unchecked_Conversion (Duration, D_Int); + function To_Duration is new Unchecked_Conversion (D_Int, Duration); + + begin + D_As_Int := To_D_As_Int (D); + Adjusted_Seconds := time_t (D_As_Int / Small_Div); + Frac_Sec := To_Duration (D_As_Int rem Small_Div); + end; + + localtime_r (Adjusted_Seconds'Unchecked_Access, Tm_Val'Unchecked_Access); + + Year_Val := Tm_Val.tm_year + 1900 + Year_Val; + Month := Tm_Val.tm_mon + 1; + Day := Tm_Val.tm_mday; + + -- The Seconds value is a little complex. The localtime function + -- returns the integral number of seconds, which is what we want, + -- but we want to retain the fractional part from the original + -- Time value, since this is typically stored more accurately. + + Seconds := Duration (Tm_Val.tm_hour * 3600 + + Tm_Val.tm_min * 60 + + Tm_Val.tm_sec) + + Frac_Sec; + + -- Note: the above expression is pretty horrible, one of these days + -- we should stop using time_of and do everything ourselves to avoid + -- these unnecessary divides and multiplies???. + + -- The Year may still be out of range, since our entry test was + -- deliberately crude. Trying to make this entry test accurate is + -- tricky due to time zone adjustment issues affecting the exact + -- boundary. It is interesting to note that whether or not a given + -- Calendar.Time value gets Time_Error when split depends on the + -- current time zone setting. + + if Year_Val not in Ada_Year_Min .. Ada_Year_Max then + raise Time_Error; + else + Year := Year_Val; + end if; + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time + is + Result_Secs : aliased time_t; + TM_Val : aliased tm; + Int_Secs : constant Integer := Integer (Seconds); + + Year_Val : Integer := Year; + Duration_Adjust : Duration := 0.0; + + begin + -- The following checks are redundant with respect to the constraint + -- error checks that should normally be made on parameters, but we + -- decide to raise Constraint_Error in any case if bad values come + -- in (as a result of checks being off in the caller, or for other + -- erroneous or bounded error cases). + + if not Year 'Valid + or else not Month 'Valid + or else not Day 'Valid + or else not Seconds'Valid + then + raise Constraint_Error; + end if; + + -- Check for Day value too large (one might expect mktime to do this + -- check, as well as the basi checks we did with 'Valid, but it seems + -- that at least on some systems, this built-in check is too weak). + + if Day > Days_In_Month (Month) + and then (Day /= 29 or Month /= 2 or Year mod 4 /= 0) + then + raise Time_Error; + end if; + + TM_Val.tm_sec := Int_Secs mod 60; + TM_Val.tm_min := (Int_Secs / 60) mod 60; + TM_Val.tm_hour := (Int_Secs / 60) / 60; + TM_Val.tm_mday := Day; + TM_Val.tm_mon := Month - 1; + + -- For the year, we have to adjust it to a year that Unix can handle. + -- We do this in four year steps, since the number of days in four + -- years is constant, so the timezone effect on the conversion from + -- local time to GMT is unaffected. + + while Year_Val <= Unix_Year_Min loop + Year_Val := Year_Val + 4; + Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD; + end loop; + + while Year_Val >= Unix_Year_Max loop + Year_Val := Year_Val - 4; + Duration_Adjust := Duration_Adjust + Seconds_In_4_YearsD; + end loop; + + TM_Val.tm_year := Year_Val - 1900; + + -- Since we do not have information on daylight savings, + -- rely on the default information. + + TM_Val.tm_isdst := -1; + Result_Secs := mktime (TM_Val'Unchecked_Access); + + -- That gives us the basic value in seconds. Two adjustments are + -- needed. First we must undo the year adjustment carried out above. + -- Second we put back the fraction seconds value since in general the + -- Day_Duration value we received has additional precision which we + -- do not want to lose in the constructed result. + + return + Time (Duration (Result_Secs) + + Duration_Adjust + + (Seconds - Duration (Int_Secs))); + + end Time_Of; + + ---------- + -- Year -- + ---------- + + function Year (Date : Time) return Year_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DY; + end Year; + +end Ada.Calendar; diff --git a/gcc/ada/a-calend.ads b/gcc/ada/a-calend.ads new file mode 100644 index 00000000000..4c2271aabd0 --- /dev/null +++ b/gcc/ada/a-calend.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Calendar is + + type Time is private; + + -- Declarations representing limits of allowed local time values. Note that + -- these do NOT constrain the possible stored values of time which may well + -- permit a larger range of times (this is explicitly allowed in Ada 95). + + subtype Year_Number is Integer range 1901 .. 2099; + subtype Month_Number is Integer range 1 .. 12; + subtype Day_Number is Integer range 1 .. 31; + + subtype Day_Duration is Duration range 0.0 .. 86_400.0; + + function Clock return Time; + + function Year (Date : Time) return Year_Number; + function Month (Date : Time) return Month_Number; + function Day (Date : Time) return Day_Number; + function Seconds (Date : Time) return Day_Duration; + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration); + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time; + + function "+" (Left : Time; Right : Duration) return Time; + function "+" (Left : Duration; Right : Time) return Time; + function "-" (Left : Time; Right : Duration) return Time; + function "-" (Left : Time; Right : Time) return Duration; + + function "<" (Left, Right : Time) return Boolean; + function "<=" (Left, Right : Time) return Boolean; + function ">" (Left, Right : Time) return Boolean; + function ">=" (Left, Right : Time) return Boolean; + + Time_Error : exception; + +private + pragma Inline (Clock); + + pragma Inline (Year); + pragma Inline (Month); + pragma Inline (Day); + + pragma Inline ("+"); + pragma Inline ("-"); + + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + + -- Time is represented as a signed duration from the base point which is + -- what Unix calls the EPOCH (i.e. 12 midnight (24:00:00), Dec 31st, 1969, + -- or if you prefer 0:00:00 on Jan 1st, 1970). Since Ada allows dates + -- before this EPOCH value, the stored duration value may be negative. + + -- The time value stored is typically a GMT value, as provided in standard + -- Unix environments. If this is the case then Split and Time_Of perform + -- required conversions to and from local times. The range of times that + -- can be stored in Time values depends on the declaration of the type + -- Duration, which must at least cover the required Ada range represented + -- by the declaration of Year_Number, but may be larger (we take full + -- advantage of the new permission in Ada 95 to store time values outside + -- the range that would be acceptable to Split). The Duration type is a + -- real value representing a time interval in seconds. + + type Time is new Duration; + +end Ada.Calendar; diff --git a/gcc/ada/a-chahan.adb b/gcc/ada/a-chahan.adb new file mode 100644 index 00000000000..dd562a13175 --- /dev/null +++ b/gcc/ada/a-chahan.adb @@ -0,0 +1,585 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; + +package body Ada.Characters.Handling is + + ------------------------------------ + -- Character Classification Table -- + ------------------------------------ + + type Character_Flags is mod 256; + for Character_Flags'Size use 8; + + Control : constant Character_Flags := 1; + Lower : constant Character_Flags := 2; + Upper : constant Character_Flags := 4; + Basic : constant Character_Flags := 8; + Hex_Digit : constant Character_Flags := 16; + Digit : constant Character_Flags := 32; + Special : constant Character_Flags := 64; + + Letter : constant Character_Flags := Lower or Upper; + Alphanum : constant Character_Flags := Letter or Digit; + Graphic : constant Character_Flags := Alphanum or Special; + + Char_Map : constant array (Character) of Character_Flags := + ( + NUL => Control, + SOH => Control, + STX => Control, + ETX => Control, + EOT => Control, + ENQ => Control, + ACK => Control, + BEL => Control, + BS => Control, + HT => Control, + LF => Control, + VT => Control, + FF => Control, + CR => Control, + SO => Control, + SI => Control, + + DLE => Control, + DC1 => Control, + DC2 => Control, + DC3 => Control, + DC4 => Control, + NAK => Control, + SYN => Control, + ETB => Control, + CAN => Control, + EM => Control, + SUB => Control, + ESC => Control, + FS => Control, + GS => Control, + RS => Control, + US => Control, + + Space => Special, + Exclamation => Special, + Quotation => Special, + Number_Sign => Special, + Dollar_Sign => Special, + Percent_Sign => Special, + Ampersand => Special, + Apostrophe => Special, + Left_Parenthesis => Special, + Right_Parenthesis => Special, + Asterisk => Special, + Plus_Sign => Special, + Comma => Special, + Hyphen => Special, + Full_Stop => Special, + Solidus => Special, + + '0' .. '9' => Digit + Hex_Digit, + + Colon => Special, + Semicolon => Special, + Less_Than_Sign => Special, + Equals_Sign => Special, + Greater_Than_Sign => Special, + Question => Special, + Commercial_At => Special, + + 'A' .. 'F' => Upper + Basic + Hex_Digit, + 'G' .. 'Z' => Upper + Basic, + + Left_Square_Bracket => Special, + Reverse_Solidus => Special, + Right_Square_Bracket => Special, + Circumflex => Special, + Low_Line => Special, + Grave => Special, + + 'a' .. 'f' => Lower + Basic + Hex_Digit, + 'g' .. 'z' => Lower + Basic, + + Left_Curly_Bracket => Special, + Vertical_Line => Special, + Right_Curly_Bracket => Special, + Tilde => Special, + + DEL => Control, + Reserved_128 => Control, + Reserved_129 => Control, + BPH => Control, + NBH => Control, + Reserved_132 => Control, + NEL => Control, + SSA => Control, + ESA => Control, + HTS => Control, + HTJ => Control, + VTS => Control, + PLD => Control, + PLU => Control, + RI => Control, + SS2 => Control, + SS3 => Control, + + DCS => Control, + PU1 => Control, + PU2 => Control, + STS => Control, + CCH => Control, + MW => Control, + SPA => Control, + EPA => Control, + + SOS => Control, + Reserved_153 => Control, + SCI => Control, + CSI => Control, + ST => Control, + OSC => Control, + PM => Control, + APC => Control, + + No_Break_Space => Special, + Inverted_Exclamation => Special, + Cent_Sign => Special, + Pound_Sign => Special, + Currency_Sign => Special, + Yen_Sign => Special, + Broken_Bar => Special, + Section_Sign => Special, + Diaeresis => Special, + Copyright_Sign => Special, + Feminine_Ordinal_Indicator => Special, + Left_Angle_Quotation => Special, + Not_Sign => Special, + Soft_Hyphen => Special, + Registered_Trade_Mark_Sign => Special, + Macron => Special, + Degree_Sign => Special, + Plus_Minus_Sign => Special, + Superscript_Two => Special, + Superscript_Three => Special, + Acute => Special, + Micro_Sign => Special, + Pilcrow_Sign => Special, + Middle_Dot => Special, + Cedilla => Special, + Superscript_One => Special, + Masculine_Ordinal_Indicator => Special, + Right_Angle_Quotation => Special, + Fraction_One_Quarter => Special, + Fraction_One_Half => Special, + Fraction_Three_Quarters => Special, + Inverted_Question => Special, + + UC_A_Grave => Upper, + UC_A_Acute => Upper, + UC_A_Circumflex => Upper, + UC_A_Tilde => Upper, + UC_A_Diaeresis => Upper, + UC_A_Ring => Upper, + UC_AE_Diphthong => Upper + Basic, + UC_C_Cedilla => Upper, + UC_E_Grave => Upper, + UC_E_Acute => Upper, + UC_E_Circumflex => Upper, + UC_E_Diaeresis => Upper, + UC_I_Grave => Upper, + UC_I_Acute => Upper, + UC_I_Circumflex => Upper, + UC_I_Diaeresis => Upper, + UC_Icelandic_Eth => Upper + Basic, + UC_N_Tilde => Upper, + UC_O_Grave => Upper, + UC_O_Acute => Upper, + UC_O_Circumflex => Upper, + UC_O_Tilde => Upper, + UC_O_Diaeresis => Upper, + + Multiplication_Sign => Special, + + UC_O_Oblique_Stroke => Upper, + UC_U_Grave => Upper, + UC_U_Acute => Upper, + UC_U_Circumflex => Upper, + UC_U_Diaeresis => Upper, + UC_Y_Acute => Upper, + UC_Icelandic_Thorn => Upper + Basic, + + LC_German_Sharp_S => Lower + Basic, + LC_A_Grave => Lower, + LC_A_Acute => Lower, + LC_A_Circumflex => Lower, + LC_A_Tilde => Lower, + LC_A_Diaeresis => Lower, + LC_A_Ring => Lower, + LC_AE_Diphthong => Lower + Basic, + LC_C_Cedilla => Lower, + LC_E_Grave => Lower, + LC_E_Acute => Lower, + LC_E_Circumflex => Lower, + LC_E_Diaeresis => Lower, + LC_I_Grave => Lower, + LC_I_Acute => Lower, + LC_I_Circumflex => Lower, + LC_I_Diaeresis => Lower, + LC_Icelandic_Eth => Lower + Basic, + LC_N_Tilde => Lower, + LC_O_Grave => Lower, + LC_O_Acute => Lower, + LC_O_Circumflex => Lower, + LC_O_Tilde => Lower, + LC_O_Diaeresis => Lower, + + Division_Sign => Special, + + LC_O_Oblique_Stroke => Lower, + LC_U_Grave => Lower, + LC_U_Acute => Lower, + LC_U_Circumflex => Lower, + LC_U_Diaeresis => Lower, + LC_Y_Acute => Lower, + LC_Icelandic_Thorn => Lower + Basic, + LC_Y_Diaeresis => Lower + ); + + --------------------- + -- Is_Alphanumeric -- + --------------------- + + function Is_Alphanumeric (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Alphanum) /= 0; + end Is_Alphanumeric; + + -------------- + -- Is_Basic -- + -------------- + + function Is_Basic (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Basic) /= 0; + end Is_Basic; + + ------------------ + -- Is_Character -- + ------------------ + + function Is_Character (Item : in Wide_Character) return Boolean is + begin + return Wide_Character'Pos (Item) < 256; + end Is_Character; + + ---------------- + -- Is_Control -- + ---------------- + + function Is_Control (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Control) /= 0; + end Is_Control; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (Item : in Character) return Boolean is + begin + return Item in '0' .. '9'; + end Is_Digit; + + ---------------- + -- Is_Graphic -- + ---------------- + + function Is_Graphic (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Graphic) /= 0; + end Is_Graphic; + + -------------------------- + -- Is_Hexadecimal_Digit -- + -------------------------- + + function Is_Hexadecimal_Digit (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Hex_Digit) /= 0; + end Is_Hexadecimal_Digit; + + ---------------- + -- Is_ISO_646 -- + ---------------- + + function Is_ISO_646 (Item : in Character) return Boolean is + begin + return Item in ISO_646; + end Is_ISO_646; + + -- Note: much more efficient coding of the following function is possible + -- by testing several 16#80# bits in a complete word in a single operation + + function Is_ISO_646 (Item : in String) return Boolean is + begin + for J in Item'Range loop + if Item (J) not in ISO_646 then + return False; + end if; + end loop; + + return True; + end Is_ISO_646; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Letter) /= 0; + end Is_Letter; + + -------------- + -- Is_Lower -- + -------------- + + function Is_Lower (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Lower) /= 0; + end Is_Lower; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Special) /= 0; + end Is_Special; + + --------------- + -- Is_String -- + --------------- + + function Is_String (Item : in Wide_String) return Boolean is + begin + for J in Item'Range loop + if Wide_Character'Pos (Item (J)) >= 256 then + return False; + end if; + end loop; + + return True; + end Is_String; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : in Character) return Boolean is + begin + return (Char_Map (Item) and Upper) /= 0; + end Is_Upper; + + -------------- + -- To_Basic -- + -------------- + + function To_Basic (Item : in Character) return Character is + begin + return Value (Basic_Map, Item); + end To_Basic; + + function To_Basic (Item : in String) return String is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); + end loop; + + return Result; + end To_Basic; + + ------------------ + -- To_Character -- + ------------------ + + function To_Character + (Item : in Wide_Character; + Substitute : in Character := ' ') + return Character + is + begin + if Is_Character (Item) then + return Character'Val (Wide_Character'Pos (Item)); + else + return Substitute; + end if; + end To_Character; + + ---------------- + -- To_ISO_646 -- + ---------------- + + function To_ISO_646 + (Item : in Character; + Substitute : in ISO_646 := ' ') + return ISO_646 + is + begin + if Item in ISO_646 then + return Item; + else + return Substitute; + end if; + end To_ISO_646; + + function To_ISO_646 + (Item : in String; + Substitute : in ISO_646 := ' ') + return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + if Item (J) in ISO_646 then + Result (J - (Item'First - 1)) := Item (J); + else + Result (J - (Item'First - 1)) := Substitute; + end if; + end loop; + + return Result; + end To_ISO_646; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : in Character) return Character is + begin + return Value (Lower_Case_Map, Item); + end To_Lower; + + function To_Lower (Item : in String) return String is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); + end loop; + + return Result; + end To_Lower; + + --------------- + -- To_String -- + --------------- + + function To_String + (Item : in Wide_String; + Substitute : in Character := ' ') + return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); + end loop; + return Result; + end To_String; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper + (Item : in Character) + return Character + is + begin + return Value (Upper_Case_Map, Item); + end To_Upper; + + function To_Upper + (Item : in String) + return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); + end loop; + + return Result; + end To_Upper; + + ----------------------- + -- To_Wide_Character -- + ----------------------- + + function To_Wide_Character + (Item : in Character) + return Wide_Character + is + begin + return Wide_Character'Val (Character'Pos (Item)); + end To_Wide_Character; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Item : in String) + return Wide_String + is + Result : Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); + end loop; + + return Result; + end To_Wide_String; +end Ada.Characters.Handling; diff --git a/gcc/ada/a-chahan.ads b/gcc/ada/a-chahan.ads new file mode 100644 index 00000000000..13027781eb6 --- /dev/null +++ b/gcc/ada/a-chahan.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + +package Ada.Characters.Handling is +pragma Preelaborate (Handling); + + ---------------------------------------- + -- Character Classification Functions -- + ---------------------------------------- + + function Is_Control (Item : in Character) return Boolean; + function Is_Graphic (Item : in Character) return Boolean; + function Is_Letter (Item : in Character) return Boolean; + function Is_Lower (Item : in Character) return Boolean; + function Is_Upper (Item : in Character) return Boolean; + function Is_Basic (Item : in Character) return Boolean; + function Is_Digit (Item : in Character) return Boolean; + function Is_Decimal_Digit (Item : in Character) return Boolean + renames Is_Digit; + function Is_Hexadecimal_Digit (Item : in Character) return Boolean; + function Is_Alphanumeric (Item : in Character) return Boolean; + function Is_Special (Item : in Character) return Boolean; + + --------------------------------------------------- + -- Conversion Functions for Character and String -- + --------------------------------------------------- + + function To_Lower (Item : in Character) return Character; + function To_Upper (Item : in Character) return Character; + function To_Basic (Item : in Character) return Character; + + function To_Lower (Item : in String) return String; + function To_Upper (Item : in String) return String; + function To_Basic (Item : in String) return String; + + ---------------------------------------------------------------------- + -- Classifications of and Conversions Between Character and ISO 646 -- + ---------------------------------------------------------------------- + + subtype ISO_646 is + Character range Character'Val (0) .. Character'Val (127); + + function Is_ISO_646 (Item : in Character) return Boolean; + function Is_ISO_646 (Item : in String) return Boolean; + + function To_ISO_646 + (Item : in Character; + Substitute : in ISO_646 := ' ') + return ISO_646; + + function To_ISO_646 + (Item : in String; + Substitute : in ISO_646 := ' ') + return String; + + ------------------------------------------------------ + -- Classifications of Wide_Character and Characters -- + ------------------------------------------------------ + + function Is_Character (Item : in Wide_Character) return Boolean; + function Is_String (Item : in Wide_String) return Boolean; + + ------------------------------------------------------ + -- Conversions between Wide_Character and Character -- + ------------------------------------------------------ + + function To_Character + (Item : in Wide_Character; + Substitute : in Character := ' ') + return Character; + + function To_String + (Item : in Wide_String; + Substitute : in Character := ' ') + return String; + + function To_Wide_Character (Item : in Character) return Wide_Character; + function To_Wide_String (Item : in String) return Wide_String; + +private + pragma Inline (Is_Control); + pragma Inline (Is_Graphic); + pragma Inline (Is_Letter); + pragma Inline (Is_Lower); + pragma Inline (Is_Upper); + pragma Inline (Is_Basic); + pragma Inline (Is_Digit); + pragma Inline (Is_Hexadecimal_Digit); + pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Special); + pragma Inline (To_Lower); + pragma Inline (To_Upper); + pragma Inline (To_Basic); + pragma Inline (Is_ISO_646); + pragma Inline (Is_Character); + pragma Inline (To_Character); + pragma Inline (To_Wide_Character); + +end Ada.Characters.Handling; diff --git a/gcc/ada/a-charac.ads b/gcc/ada/a-charac.ads new file mode 100644 index 00000000000..127e7b0be28 --- /dev/null +++ b/gcc/ada/a-charac.ads @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + + +package Ada.Characters is +pragma Pure (Characters); + +end Ada.Characters; diff --git a/gcc/ada/a-chlat1.ads b/gcc/ada/a-chlat1.ads new file mode 100644 index 00000000000..0cee32e3ad9 --- /dev/null +++ b/gcc/ada/a-chlat1.ads @@ -0,0 +1,297 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters.Latin_1 is +pragma Pure (Latin_1); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Character := Character'Val (0); + SOH : constant Character := Character'Val (1); + STX : constant Character := Character'Val (2); + ETX : constant Character := Character'Val (3); + EOT : constant Character := Character'Val (4); + ENQ : constant Character := Character'Val (5); + ACK : constant Character := Character'Val (6); + BEL : constant Character := Character'Val (7); + BS : constant Character := Character'Val (8); + HT : constant Character := Character'Val (9); + LF : constant Character := Character'Val (10); + VT : constant Character := Character'Val (11); + FF : constant Character := Character'Val (12); + CR : constant Character := Character'Val (13); + SO : constant Character := Character'Val (14); + SI : constant Character := Character'Val (15); + + DLE : constant Character := Character'Val (16); + DC1 : constant Character := Character'Val (17); + DC2 : constant Character := Character'Val (18); + DC3 : constant Character := Character'Val (19); + DC4 : constant Character := Character'Val (20); + NAK : constant Character := Character'Val (21); + SYN : constant Character := Character'Val (22); + ETB : constant Character := Character'Val (23); + CAN : constant Character := Character'Val (24); + EM : constant Character := Character'Val (25); + SUB : constant Character := Character'Val (26); + ESC : constant Character := Character'Val (27); + FS : constant Character := Character'Val (28); + GS : constant Character := Character'Val (29); + RS : constant Character := Character'Val (30); + US : constant Character := Character'Val (31); + + -------------------------------- + -- ISO 646 Graphic Characters -- + -------------------------------- + + Space : constant Character := ' '; -- Character'Val(32) + Exclamation : constant Character := '!'; -- Character'Val(33) + Quotation : constant Character := '"'; -- Character'Val(34) + Number_Sign : constant Character := '#'; -- Character'Val(35) + Dollar_Sign : constant Character := '$'; -- Character'Val(36) + Percent_Sign : constant Character := '%'; -- Character'Val(37) + Ampersand : constant Character := '&'; -- Character'Val(38) + Apostrophe : constant Character := '''; -- Character'Val(39) + Left_Parenthesis : constant Character := '('; -- Character'Val(40) + Right_Parenthesis : constant Character := ')'; -- Character'Val(41) + Asterisk : constant Character := '*'; -- Character'Val(42) + Plus_Sign : constant Character := '+'; -- Character'Val(43) + Comma : constant Character := ','; -- Character'Val(44) + Hyphen : constant Character := '-'; -- Character'Val(45) + Minus_Sign : Character renames Hyphen; + Full_Stop : constant Character := '.'; -- Character'Val(46) + Solidus : constant Character := '/'; -- Character'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Character := ':'; -- Character'Val(58) + Semicolon : constant Character := ';'; -- Character'Val(59) + Less_Than_Sign : constant Character := '<'; -- Character'Val(60) + Equals_Sign : constant Character := '='; -- Character'Val(61) + Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) + Question : constant Character := '?'; -- Character'Val(63) + + Commercial_At : constant Character := '@'; -- Character'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Character := '['; -- Character'Val (91) + Reverse_Solidus : constant Character := '\'; -- Character'Val (92) + Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) + Circumflex : constant Character := '^'; -- Character'Val (94) + Low_Line : constant Character := '_'; -- Character'Val (95) + + Grave : constant Character := '`'; -- Character'Val (96) + LC_A : constant Character := 'a'; -- Character'Val (97) + LC_B : constant Character := 'b'; -- Character'Val (98) + LC_C : constant Character := 'c'; -- Character'Val (99) + LC_D : constant Character := 'd'; -- Character'Val (100) + LC_E : constant Character := 'e'; -- Character'Val (101) + LC_F : constant Character := 'f'; -- Character'Val (102) + LC_G : constant Character := 'g'; -- Character'Val (103) + LC_H : constant Character := 'h'; -- Character'Val (104) + LC_I : constant Character := 'i'; -- Character'Val (105) + LC_J : constant Character := 'j'; -- Character'Val (106) + LC_K : constant Character := 'k'; -- Character'Val (107) + LC_L : constant Character := 'l'; -- Character'Val (108) + LC_M : constant Character := 'm'; -- Character'Val (109) + LC_N : constant Character := 'n'; -- Character'Val (110) + LC_O : constant Character := 'o'; -- Character'Val (111) + LC_P : constant Character := 'p'; -- Character'Val (112) + LC_Q : constant Character := 'q'; -- Character'Val (113) + LC_R : constant Character := 'r'; -- Character'Val (114) + LC_S : constant Character := 's'; -- Character'Val (115) + LC_T : constant Character := 't'; -- Character'Val (116) + LC_U : constant Character := 'u'; -- Character'Val (117) + LC_V : constant Character := 'v'; -- Character'Val (118) + LC_W : constant Character := 'w'; -- Character'Val (119) + LC_X : constant Character := 'x'; -- Character'Val (120) + LC_Y : constant Character := 'y'; -- Character'Val (121) + LC_Z : constant Character := 'z'; -- Character'Val (122) + Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) + Vertical_Line : constant Character := '|'; -- Character'Val (124) + Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) + Tilde : constant Character := '~'; -- Character'Val (126) + DEL : constant Character := Character'Val (127); + + --------------------------------- + -- ISO 6429 Control Characters -- + --------------------------------- + + IS4 : Character renames FS; + IS3 : Character renames GS; + IS2 : Character renames RS; + IS1 : Character renames US; + + Reserved_128 : constant Character := Character'Val (128); + Reserved_129 : constant Character := Character'Val (129); + BPH : constant Character := Character'Val (130); + NBH : constant Character := Character'Val (131); + Reserved_132 : constant Character := Character'Val (132); + NEL : constant Character := Character'Val (133); + SSA : constant Character := Character'Val (134); + ESA : constant Character := Character'Val (135); + HTS : constant Character := Character'Val (136); + HTJ : constant Character := Character'Val (137); + VTS : constant Character := Character'Val (138); + PLD : constant Character := Character'Val (139); + PLU : constant Character := Character'Val (140); + RI : constant Character := Character'Val (141); + SS2 : constant Character := Character'Val (142); + SS3 : constant Character := Character'Val (143); + + DCS : constant Character := Character'Val (144); + PU1 : constant Character := Character'Val (145); + PU2 : constant Character := Character'Val (146); + STS : constant Character := Character'Val (147); + CCH : constant Character := Character'Val (148); + MW : constant Character := Character'Val (149); + SPA : constant Character := Character'Val (150); + EPA : constant Character := Character'Val (151); + + SOS : constant Character := Character'Val (152); + Reserved_153 : constant Character := Character'Val (153); + SCI : constant Character := Character'Val (154); + CSI : constant Character := Character'Val (155); + ST : constant Character := Character'Val (156); + OSC : constant Character := Character'Val (157); + PM : constant Character := Character'Val (158); + APC : constant Character := Character'Val (159); + + ------------------------------ + -- Other Graphic Characters -- + ------------------------------ + + -- Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Character := Character'Val (160); + NBSP : Character renames No_Break_Space; + Inverted_Exclamation : constant Character := Character'Val (161); + Cent_Sign : constant Character := Character'Val (162); + Pound_Sign : constant Character := Character'Val (163); + Currency_Sign : constant Character := Character'Val (164); + Yen_Sign : constant Character := Character'Val (165); + Broken_Bar : constant Character := Character'Val (166); + Section_Sign : constant Character := Character'Val (167); + Diaeresis : constant Character := Character'Val (168); + Copyright_Sign : constant Character := Character'Val (169); + Feminine_Ordinal_Indicator : constant Character := Character'Val (170); + Left_Angle_Quotation : constant Character := Character'Val (171); + Not_Sign : constant Character := Character'Val (172); + Soft_Hyphen : constant Character := Character'Val (173); + Registered_Trade_Mark_Sign : constant Character := Character'Val (174); + Macron : constant Character := Character'Val (175); + + -- Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Character := Character'Val (176); + Ring_Above : Character renames Degree_Sign; + Plus_Minus_Sign : constant Character := Character'Val (177); + Superscript_Two : constant Character := Character'Val (178); + Superscript_Three : constant Character := Character'Val (179); + Acute : constant Character := Character'Val (180); + Micro_Sign : constant Character := Character'Val (181); + Pilcrow_Sign : constant Character := Character'Val (182); + Paragraph_Sign : Character renames Pilcrow_Sign; + Middle_Dot : constant Character := Character'Val (183); + Cedilla : constant Character := Character'Val (184); + Superscript_One : constant Character := Character'Val (185); + Masculine_Ordinal_Indicator : constant Character := Character'Val (186); + Right_Angle_Quotation : constant Character := Character'Val (187); + Fraction_One_Quarter : constant Character := Character'Val (188); + Fraction_One_Half : constant Character := Character'Val (189); + Fraction_Three_Quarters : constant Character := Character'Val (190); + Inverted_Question : constant Character := Character'Val (191); + + -- Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Character := Character'Val (192); + UC_A_Acute : constant Character := Character'Val (193); + UC_A_Circumflex : constant Character := Character'Val (194); + UC_A_Tilde : constant Character := Character'Val (195); + UC_A_Diaeresis : constant Character := Character'Val (196); + UC_A_Ring : constant Character := Character'Val (197); + UC_AE_Diphthong : constant Character := Character'Val (198); + UC_C_Cedilla : constant Character := Character'Val (199); + UC_E_Grave : constant Character := Character'Val (200); + UC_E_Acute : constant Character := Character'Val (201); + UC_E_Circumflex : constant Character := Character'Val (202); + UC_E_Diaeresis : constant Character := Character'Val (203); + UC_I_Grave : constant Character := Character'Val (204); + UC_I_Acute : constant Character := Character'Val (205); + UC_I_Circumflex : constant Character := Character'Val (206); + UC_I_Diaeresis : constant Character := Character'Val (207); + + -- Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Character := Character'Val (208); + UC_N_Tilde : constant Character := Character'Val (209); + UC_O_Grave : constant Character := Character'Val (210); + UC_O_Acute : constant Character := Character'Val (211); + UC_O_Circumflex : constant Character := Character'Val (212); + UC_O_Tilde : constant Character := Character'Val (213); + UC_O_Diaeresis : constant Character := Character'Val (214); + Multiplication_Sign : constant Character := Character'Val (215); + UC_O_Oblique_Stroke : constant Character := Character'Val (216); + UC_U_Grave : constant Character := Character'Val (217); + UC_U_Acute : constant Character := Character'Val (218); + UC_U_Circumflex : constant Character := Character'Val (219); + UC_U_Diaeresis : constant Character := Character'Val (220); + UC_Y_Acute : constant Character := Character'Val (221); + UC_Icelandic_Thorn : constant Character := Character'Val (222); + LC_German_Sharp_S : constant Character := Character'Val (223); + + -- Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Character := Character'Val (224); + LC_A_Acute : constant Character := Character'Val (225); + LC_A_Circumflex : constant Character := Character'Val (226); + LC_A_Tilde : constant Character := Character'Val (227); + LC_A_Diaeresis : constant Character := Character'Val (228); + LC_A_Ring : constant Character := Character'Val (229); + LC_AE_Diphthong : constant Character := Character'Val (230); + LC_C_Cedilla : constant Character := Character'Val (231); + LC_E_Grave : constant Character := Character'Val (232); + LC_E_Acute : constant Character := Character'Val (233); + LC_E_Circumflex : constant Character := Character'Val (234); + LC_E_Diaeresis : constant Character := Character'Val (235); + LC_I_Grave : constant Character := Character'Val (236); + LC_I_Acute : constant Character := Character'Val (237); + LC_I_Circumflex : constant Character := Character'Val (238); + LC_I_Diaeresis : constant Character := Character'Val (239); + + -- Character positions 240 (16#F0#) .. 255 (16#FF) + LC_Icelandic_Eth : constant Character := Character'Val (240); + LC_N_Tilde : constant Character := Character'Val (241); + LC_O_Grave : constant Character := Character'Val (242); + LC_O_Acute : constant Character := Character'Val (243); + LC_O_Circumflex : constant Character := Character'Val (244); + LC_O_Tilde : constant Character := Character'Val (245); + LC_O_Diaeresis : constant Character := Character'Val (246); + Division_Sign : constant Character := Character'Val (247); + LC_O_Oblique_Stroke : constant Character := Character'Val (248); + LC_U_Grave : constant Character := Character'Val (249); + LC_U_Acute : constant Character := Character'Val (250); + LC_U_Circumflex : constant Character := Character'Val (251); + LC_U_Diaeresis : constant Character := Character'Val (252); + LC_Y_Acute : constant Character := Character'Val (253); + LC_Icelandic_Thorn : constant Character := Character'Val (254); + LC_Y_Diaeresis : constant Character := Character'Val (255); + +end Ada.Characters.Latin_1; diff --git a/gcc/ada/a-colien.adb b/gcc/ada/a-colien.adb new file mode 100644 index 00000000000..a4093f3551f --- /dev/null +++ b/gcc/ada/a-colien.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; +package body Ada.Command_Line.Environment is + + ----------------------- + -- Environment_Count -- + ----------------------- + + function Environment_Count return Natural is + function Env_Count return Natural; + pragma Import (C, Env_Count, "__gnat_env_count"); + + begin + return Env_Count; + end Environment_Count; + + ----------------------- + -- Environment_Value -- + ----------------------- + + function Environment_Value (Number : in Positive) return String is + procedure Fill_Env (E : System.Address; Env_Num : Integer); + pragma Import (C, Fill_Env, "__gnat_fill_env"); + + function Len_Env (Env_Num : Integer) return Integer; + pragma Import (C, Len_Env, "__gnat_len_env"); + + begin + if Number > Environment_Count then + raise Constraint_Error; + end if; + + declare + Env : aliased String (1 .. Len_Env (Number - 1)); + begin + Fill_Env (Env'Address, Number - 1); + return Env; + end; + end Environment_Value; + +end Ada.Command_Line.Environment; diff --git a/gcc/ada/a-colien.ads b/gcc/ada/a-colien.ads new file mode 100644 index 00000000000..bb0fd26f040 --- /dev/null +++ b/gcc/ada/a-colien.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Command_Line.Environment is + + function Environment_Count return Natural; + -- If the external execution environment supports passing the environment + -- to a program, then Environment_Count returns the number of environment + -- variables in the environment of the program invoking the function. + -- Otherwise it returns 0. And that's a lot of environment. + + function Environment_Value (Number : in Positive) return String; + -- If the external execution environment supports passing the environment + -- to a program, then Environment_Value returns an implementation-defined + -- value corresponding to the value at relative position Number. If Number + -- is outside the range 1 .. Environment_Count, then Constraint_Error is + -- propagated. + -- + -- in GNAT: Corresponds to envp [n-1] (for n > 0) in C. + +end Ada.Command_Line.Environment; diff --git a/gcc/ada/a-colire.adb b/gcc/ada/a-colire.adb new file mode 100644 index 00000000000..8188ae742a6 --- /dev/null +++ b/gcc/ada/a-colire.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E M O V E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Command_Line.Remove is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize; + -- Initialize the Remove_Count and Remove_Args variables. + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if Remove_Args = null then + Remove_Count := Argument_Count; + Remove_Args := new Arg_Nums (1 .. Argument_Count); + + for J in Remove_Args'Range loop + Remove_Args (J) := J; + end loop; + end if; + end Initialize; + + --------------------- + -- Remove_Argument -- + --------------------- + + procedure Remove_Argument (Number : in Positive) is + begin + Initialize; + + if Number > Remove_Count then + raise Constraint_Error; + end if; + + Remove_Count := Remove_Count - 1; + + for J in Number .. Remove_Count loop + Remove_Args (J) := Remove_Args (J + 1); + end loop; + end Remove_Argument; + + procedure Remove_Argument (Argument : String) is + begin + for J in reverse 1 .. Argument_Count loop + if Argument = Ada.Command_Line.Argument (J) then + Remove_Argument (J); + end if; + end loop; + end Remove_Argument; + + ---------------------- + -- Remove_Arguments -- + ---------------------- + + procedure Remove_Arguments (From : Positive; To : Natural) is + begin + Initialize; + + if From > Remove_Count + or else To > Remove_Count + then + raise Constraint_Error; + end if; + + if To >= From then + Remove_Count := Remove_Count - (To - From + 1); + + for J in From .. Remove_Count loop + Remove_Args (J) := Remove_Args (J + (To - From + 1)); + end loop; + end if; + end Remove_Arguments; + + procedure Remove_Arguments (Argument_Prefix : String) is + begin + for J in reverse 1 .. Argument_Count loop + declare + Arg : constant String := Argument (J); + + begin + if Arg'Length >= Argument_Prefix'Length + and then Arg (1 .. Argument_Prefix'Length) = Argument_Prefix + then + Remove_Argument (J); + end if; + end; + end loop; + end Remove_Arguments; + +end Ada.Command_Line.Remove; diff --git a/gcc/ada/a-colire.ads b/gcc/ada/a-colire.ads new file mode 100644 index 00000000000..59e77bd15dd --- /dev/null +++ b/gcc/ada/a-colire.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E M O V E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package is intended to be used in conjunction with its parent unit, +-- Ada.Command_Line. It provides facilities for logically removing arguments +-- from the command line, so that subsequent calls to Argument_Count and +-- Argument will reflect the removals. + +-- For example, if the original command line has three arguments A B C, so +-- that Argument_Count is initially three, then after removing B, the second +-- argument, Argument_Count will be 2, and Argument (2) will return C. + +package Ada.Command_Line.Remove is +pragma Preelaborate (Remove); + + procedure Remove_Argument (Number : in Positive); + -- Removes the argument identified by Number, which must be in the + -- range 1 .. Argument_Count (i.e. an in range argument number which + -- reflects removals). If Number is out of range Constraint_Error + -- will be raised. + -- + -- Note: the numbering of arguments greater than Number is affected + -- by the call. If you need a loop through the arguments, removing + -- some as you go, run the loop in reverse to avoid confusion from + -- this renumbering: + -- + -- for J in reverse 1 .. Argument_Count loop + -- if Should_Remove (Arguments (J)) then + -- Remove_Argument (J); + -- end if; + -- end loop; + -- + -- Reversing the loop in this manner avoids the confusion. + + procedure Remove_Arguments (From : Positive; To : Natural); + -- Removes arguments in the given From..To range. From must be in the + -- range 1 .. Argument_Count and To in the range 0 .. Argument_Count. + -- Constraint_Error is raised if either argument is out of range. If + -- To is less than From, then the call has no effect. + + procedure Remove_Argument (Argument : String); + -- Removes the argument which matches the given string Argument. Has + -- no effect if no argument matches the string. If more than one + -- argument matches the string, all are removed. + + procedure Remove_Arguments (Argument_Prefix : String); + -- Removes all arguments whose prefix matches Argument_Prefix. Has + -- no effect if no argument matches the string. For example a call + -- to Remove_Arguments ("--") removes all arguments starting with --. + +end Ada.Command_Line.Remove; diff --git a/gcc/ada/a-comlin.adb b/gcc/ada/a-comlin.adb new file mode 100644 index 00000000000..611f625ca96 --- /dev/null +++ b/gcc/ada/a-comlin.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; +package body Ada.Command_Line is + + function Arg_Count return Natural; + pragma Import (C, Arg_Count, "__gnat_arg_count"); + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + + -------------- + -- Argument -- + -------------- + + function Argument (Number : in Positive) return String is + Num : Positive; + + begin + if Number > Argument_Count then + raise Constraint_Error; + end if; + + if Remove_Args = null then + Num := Number; + else + Num := Remove_Args (Number); + end if; + + declare + Arg : aliased String (1 .. Len_Arg (Num)); + + begin + Fill_Arg (Arg'Address, Num); + return Arg; + end; + end Argument; + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + if Remove_Args = null then + return Arg_Count - 1; + else + return Remove_Count; + end if; + end Argument_Count; + + ------------------ + -- Command_Name -- + ------------------ + + function Command_Name return String is + Arg : aliased String (1 .. Len_Arg (0)); + + begin + Fill_Arg (Arg'Address, 0); + return Arg; + end Command_Name; + +end Ada.Command_Line; diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads new file mode 100644 index 00000000000..b7848e7aa5f --- /dev/null +++ b/gcc/ada/a-comlin.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Command_Line is +pragma Preelaborate (Command_Line); + + function Argument_Count return Natural; + -- If the external execution environment supports passing arguments to a + -- program, then Argument_Count returns the number of arguments passed to + -- the program invoking the function. Otherwise it return 0. + -- + -- In GNAT: Corresponds to (argc - 1) in C. + + function Argument (Number : Positive) return String; + -- If the external execution environment supports passing arguments to + -- a program, then Argument returns an implementation-defined value + -- corresponding to the argument at relative position Number. If Number + -- is outside the range 1 .. Argument_Count, then Constraint_Error is + -- propagated. + -- + -- in GNAT: Corresponds to argv [n] (for n > 0) in C. + + function Command_Name return String; + -- If the external execution environment supports passing arguments to + -- a program, then Command_Name returns an implementation-defined value + -- corresponding to the name of the command invoking the program. + -- Otherwise Command_Name returns the null string. + -- + -- in GNAT: Corresponds to argv [0] in C. + + type Exit_Status is new Integer; + + Success : constant Exit_Status; + Failure : constant Exit_Status; + + procedure Set_Exit_Status (Code : Exit_Status); + +private + + Success : constant Exit_Status := 0; + Failure : constant Exit_Status := 1; + + -- The following locations support the operation of the package + -- Ada.Command_Line_Remove, whih provides facilities for logically + -- removing arguments from the command line. If one of the remove + -- procedures is called in this unit, then Remove_Args/Remove_Count + -- are set to indicate which arguments are removed. If no such calls + -- have been made, then Remove_Args is null. + + Remove_Count : Natural; + -- Number of arguments reflecting removals. Not defined unless + -- Remove_Args is non-null. + + type Arg_Nums is array (Positive range <>) of Positive; + type Arg_Nums_Ptr is access Arg_Nums; + -- An array that maps logical argument numbers (reflecting removal) + -- to physical argument numbers (e.g. if the first argument has been + -- removed, but not the second, then Arg_Nums (1) will be set to 2. + + Remove_Args : Arg_Nums_Ptr := null; + -- Left set to null if no remove calls have been made, otherwise set + -- to point to an appropriate mapping array. Only the first Remove_Count + -- elements are relevant. + + pragma Import (C, Set_Exit_Status, "__gnat_set_exit_status"); + +end Ada.Command_Line; diff --git a/gcc/ada/a-cwila1.ads b/gcc/ada/a-cwila1.ads new file mode 100644 index 00000000000..03ef07f59c7 --- /dev/null +++ b/gcc/ada/a-cwila1.ads @@ -0,0 +1,326 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the RM defined +-- package Ada.Characters.Latin_1 except that the type of the constants +-- is Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Latin_1 is +pragma Pure (Wide_Latin_1); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Character := Wide_Character'Val (0); + SOH : constant Wide_Character := Wide_Character'Val (1); + STX : constant Wide_Character := Wide_Character'Val (2); + ETX : constant Wide_Character := Wide_Character'Val (3); + EOT : constant Wide_Character := Wide_Character'Val (4); + ENQ : constant Wide_Character := Wide_Character'Val (5); + ACK : constant Wide_Character := Wide_Character'Val (6); + BEL : constant Wide_Character := Wide_Character'Val (7); + BS : constant Wide_Character := Wide_Character'Val (8); + HT : constant Wide_Character := Wide_Character'Val (9); + LF : constant Wide_Character := Wide_Character'Val (10); + VT : constant Wide_Character := Wide_Character'Val (11); + FF : constant Wide_Character := Wide_Character'Val (12); + CR : constant Wide_Character := Wide_Character'Val (13); + SO : constant Wide_Character := Wide_Character'Val (14); + SI : constant Wide_Character := Wide_Character'Val (15); + + DLE : constant Wide_Character := Wide_Character'Val (16); + DC1 : constant Wide_Character := Wide_Character'Val (17); + DC2 : constant Wide_Character := Wide_Character'Val (18); + DC3 : constant Wide_Character := Wide_Character'Val (19); + DC4 : constant Wide_Character := Wide_Character'Val (20); + NAK : constant Wide_Character := Wide_Character'Val (21); + SYN : constant Wide_Character := Wide_Character'Val (22); + ETB : constant Wide_Character := Wide_Character'Val (23); + CAN : constant Wide_Character := Wide_Character'Val (24); + EM : constant Wide_Character := Wide_Character'Val (25); + SUB : constant Wide_Character := Wide_Character'Val (26); + ESC : constant Wide_Character := Wide_Character'Val (27); + FS : constant Wide_Character := Wide_Character'Val (28); + GS : constant Wide_Character := Wide_Character'Val (29); + RS : constant Wide_Character := Wide_Character'Val (30); + US : constant Wide_Character := Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Character renames Hyphen; + Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Character := Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Character renames FS; + IS3 : Wide_Character renames GS; + IS2 : Wide_Character renames RS; + IS1 : Wide_Character renames US; + + Reserved_128 : constant Wide_Character := Wide_Character'Val (128); + Reserved_129 : constant Wide_Character := Wide_Character'Val (129); + BPH : constant Wide_Character := Wide_Character'Val (130); + NBH : constant Wide_Character := Wide_Character'Val (131); + Reserved_132 : constant Wide_Character := Wide_Character'Val (132); + NEL : constant Wide_Character := Wide_Character'Val (133); + SSA : constant Wide_Character := Wide_Character'Val (134); + ESA : constant Wide_Character := Wide_Character'Val (135); + HTS : constant Wide_Character := Wide_Character'Val (136); + HTJ : constant Wide_Character := Wide_Character'Val (137); + VTS : constant Wide_Character := Wide_Character'Val (138); + PLD : constant Wide_Character := Wide_Character'Val (139); + PLU : constant Wide_Character := Wide_Character'Val (140); + RI : constant Wide_Character := Wide_Character'Val (141); + SS2 : constant Wide_Character := Wide_Character'Val (142); + SS3 : constant Wide_Character := Wide_Character'Val (143); + + DCS : constant Wide_Character := Wide_Character'Val (144); + PU1 : constant Wide_Character := Wide_Character'Val (145); + PU2 : constant Wide_Character := Wide_Character'Val (146); + STS : constant Wide_Character := Wide_Character'Val (147); + CCH : constant Wide_Character := Wide_Character'Val (148); + MW : constant Wide_Character := Wide_Character'Val (149); + SPA : constant Wide_Character := Wide_Character'Val (150); + EPA : constant Wide_Character := Wide_Character'Val (151); + + SOS : constant Wide_Character := Wide_Character'Val (152); + Reserved_153 : constant Wide_Character := Wide_Character'Val (153); + SCI : constant Wide_Character := Wide_Character'Val (154); + CSI : constant Wide_Character := Wide_Character'Val (155); + ST : constant Wide_Character := Wide_Character'Val (156); + OSC : constant Wide_Character := Wide_Character'Val (157); + PM : constant Wide_Character := Wide_Character'Val (158); + APC : constant Wide_Character := Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Characters -- + ----------------------------------- + + -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Wide_Character := Wide_Character'Val (160); + NBSP : Wide_Character renames No_Break_Space; + Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); + Cent_Sign : constant Wide_Character := Wide_Character'Val (162); + Pound_Sign : constant Wide_Character := Wide_Character'Val (163); + Currency_Sign : constant Wide_Character := Wide_Character'Val (164); + Yen_Sign : constant Wide_Character := Wide_Character'Val (165); + Broken_Bar : constant Wide_Character := Wide_Character'Val (166); + Section_Sign : constant Wide_Character := Wide_Character'Val (167); + Diaeresis : constant Wide_Character := Wide_Character'Val (168); + Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (170); + Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); + Not_Sign : constant Wide_Character := Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Character := Wide_Character'Val (174); + Macron : constant Wide_Character := Wide_Character'Val (175); + + -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Character := Wide_Character'Val (176); + Ring_Above : Wide_Character renames Degree_Sign; + Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); + Superscript_Two : constant Wide_Character := Wide_Character'Val (178); + Superscript_Three : constant Wide_Character := Wide_Character'Val (179); + Acute : constant Wide_Character := Wide_Character'Val (180); + Micro_Sign : constant Wide_Character := Wide_Character'Val (181); + Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); + Paragraph_Sign : Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Character := Wide_Character'Val (183); + Cedilla : constant Wide_Character := Wide_Character'Val (184); + Superscript_One : constant Wide_Character := Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Character := Wide_Character'Val (187); + Fraction_One_Quarter : constant Wide_Character := Wide_Character'Val (188); + Fraction_One_Half : constant Wide_Character := Wide_Character'Val (189); + Fraction_Three_Quarters + : constant Wide_Character := Wide_Character'Val (190); + Inverted_Question : constant Wide_Character := Wide_Character'Val (191); + + -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); + UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); + UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); + UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); + UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); + UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); + UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); + UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); + UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); + UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); + UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); + UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); + UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); + UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); + UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); + + -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); + UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); + UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); + UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); + UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); + Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); + UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); + UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); + UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); + UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); + UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); + UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); + LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); + + -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); + LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); + LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); + LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); + LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); + LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); + LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); + LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); + LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); + LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); + LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); + LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); + LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); + LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); + LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); + + -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); + LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); + LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); + LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); + LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); + Division_Sign : constant Wide_Character := Wide_Character'Val (247); + LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); + LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); + LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); + LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); + LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); + LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); + LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); + +end Ada.Characters.Wide_Latin_1; diff --git a/gcc/ada/a-decima.adb b/gcc/ada/a-decima.adb new file mode 100644 index 00000000000..b407bb09536 --- /dev/null +++ b/gcc/ada/a-decima.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . D E C I M A L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Decimal is + + ------------ + -- Divide -- + ------------ + + procedure Divide + (Dividend : in Dividend_Type; + Divisor : in Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type) + is + -- We have a nested procedure that is the actual intrinsic divide. + -- This is required because in the current RM, Divide itself does + -- not have convention Intrinsic. + + procedure Divide + (Dividend : in Dividend_Type; + Divisor : in Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type); + + pragma Import (Intrinsic, Divide); + + begin + Divide (Dividend, Divisor, Quotient, Remainder); + end Divide; + +end Ada.Decimal; diff --git a/gcc/ada/a-decima.ads b/gcc/ada/a-decima.ads new file mode 100644 index 00000000000..34881ae9c99 --- /dev/null +++ b/gcc/ada/a-decima.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D E C I M A L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Decimal is +pragma Pure (Decimal); + + -- The compiler makes a number of assumptions based on the following five + -- constants (e.g. there is an assumption that decimal values can always + -- be represented in 64-bit signed binary form), so code modifications are + -- required to increase these constants. + + Max_Scale : constant := +18; + Min_Scale : constant := -18; + + Min_Delta : constant := 1.0E-18; + Max_Delta : constant := 1.0E+18; + + Max_Decimal_Digits : constant := 18; + + generic + type Dividend_Type is delta <> digits <>; + type Divisor_Type is delta <> digits <>; + type Quotient_Type is delta <> digits <>; + type Remainder_Type is delta <> digits <>; + + procedure Divide + (Dividend : in Dividend_Type; + Divisor : in Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type); + +private + pragma Inline (Divide); + +end Ada.Decimal; diff --git a/gcc/ada/a-diocst.adb b/gcc/ada/a-diocst.adb new file mode 100644 index 00000000000..13e6c32cbf8 --- /dev/null +++ b/gcc/ada/a-diocst.adb @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with System.Direct_IO; +with Unchecked_Conversion; + +package body Ada.Direct_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package DIO renames System.Direct_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in FILEs; + Form : in String := "") + is + File_Control_Block : DIO.Direct_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => To_FCB (Mode), + Name => "", + Form => Form, + Amethod => 'D', + Creat => False, + Text => False, + C_Stream => C_Stream); + + File.Bytes := Bytes; + end Open; + +end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/a-diocst.ads b/gcc/ada/a-diocst.ads new file mode 100644 index 00000000000..4f1dd19471c --- /dev/null +++ b/gcc/ada/a-diocst.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Direct_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Direct_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in ICS.FILEs; + Form : in String := ""); + -- Create new file from existing stream + +end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb new file mode 100644 index 00000000000..f4a823a6ffc --- /dev/null +++ b/gcc/ada/a-direio.adb @@ -0,0 +1,273 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.22 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Direct_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Direct_IO +-- (for specialized Direct_IO functions) + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.File_Control_Block; +with System.File_IO; +with System.Direct_IO; +with System.Storage_Elements; +with Unchecked_Conversion; + +use type System.Direct_IO.Count; + +package body Ada.Direct_IO is + + Zeroes : System.Storage_Elements.Storage_Array := + (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); + -- Buffer used to fill out partial records. + + package FCB renames System.File_Control_Block; + package FIO renames System.File_IO; + package DIO renames System.Direct_IO; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is DIO.File_Type; + subtype DCount is DIO.Count; + subtype DPCount is DIO.Positive_Count; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : in File_Mode := Inout_File; + Name : in String := ""; + Form : in String := "") + is + begin + DIO.Create (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : in File_Type) return Boolean is + begin + return DIO.End_Of_File (FP (File)); + end End_Of_File; + + ---------- + -- Form -- + ---------- + + function Form (File : in File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ----------- + -- Index -- + ----------- + + function Index (File : in File_Type) return Positive_Count is + begin + return Positive_Count (DIO.Index (FP (File))); + end Index; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : in File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : in File_Type) return File_Mode is + begin + return To_DIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : in File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + Name : in String; + Form : in String := "") + is + begin + DIO.Open (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : in File_Type; + Item : out Element_Type; + From : in Positive_Count) + is + begin + -- For a non-constrained variant record type, we read into an + -- intermediate buffer, since we may have the case of discriminated + -- records where a discriminant check is required, and we may need + -- to assign only part of the record buffer originally written + + if not Element_Type'Constrained then + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From)); + Item := Buf; + end; + + -- In the normal case, we can read straight into the buffer + + else + DIO.Read (FP (File), Item'Address, Bytes, DPCount (From)); + end if; + end Read; + + procedure Read (File : in File_Type; Item : out Element_Type) is + begin + -- Same processing for unconstrained case as above + + if not Element_Type'Constrained then + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes); + Item := Buf; + end; + + else + DIO.Read (FP (File), Item'Address, Bytes); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : in File_Mode) is + begin + DIO.Reset (FP (File), To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + DIO.Reset (FP (File)); + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (File : in File_Type; To : in Positive_Count) is + begin + DIO.Set_Index (FP (File), DPCount (To)); + end Set_Index; + + ---------- + -- Size -- + ---------- + + function Size (File : in File_Type) return Count is + begin + return Count (DIO.Size (FP (File))); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : in File_Type; + Item : in Element_Type; + To : in Positive_Count) + is + begin + DIO.Set_Index (FP (File), DPCount (To)); + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + + procedure Write (File : in File_Type; Item : in Element_Type) is + begin + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + +end Ada.Direct_IO; diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads new file mode 100644 index 00000000000..2b301e1c667 --- /dev/null +++ b/gcc/ada/a-direio.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + +with Ada.IO_Exceptions; +with System.Direct_IO; +with Interfaces.C_Streams; + +generic + type Element_Type is private; + +package Ada.Direct_IO is + + type File_Type is limited private; + + type File_Mode is (In_File, Inout_File, Out_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) + Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File); + Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File) + + type Count is range 0 .. System.Direct_IO.Count'Last; + + subtype Positive_Count is Count range 1 .. Count'Last; + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : in File_Mode := Inout_File; + Name : in String := ""; + Form : in String := ""); + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + Name : in String; + Form : in String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : in File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : in File_Type) return File_Mode; + function Name (File : in File_Type) return String; + function Form (File : in File_Type) return String; + + function Is_Open (File : in File_Type) return Boolean; + + --------------------------------- + -- Input and Output Operations -- + --------------------------------- + + procedure Read + (File : in File_Type; + Item : out Element_Type; + From : in Positive_Count); + + procedure Read + (File : in File_Type; + Item : out Element_Type); + + procedure Write + (File : in File_Type; + Item : in Element_Type; + To : in Positive_Count); + + procedure Write + (File : in File_Type; + Item : in Element_Type); + + procedure Set_Index (File : in File_Type; To : in Positive_Count); + + function Index (File : in File_Type) return Positive_Count; + function Size (File : in File_Type) return Count; + + function End_Of_File (File : in File_Type) return Boolean; + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + +private + type File_Type is new System.Direct_IO.File_Type; + + Bytes : constant Interfaces.C_Streams.size_t := + Element_Type'Max_Size_In_Storage_Elements; + -- Size of an element in storage units + + pragma Inline (Close); + pragma Inline (Create); + pragma Inline (Delete); + pragma Inline (End_Of_File); + pragma Inline (Form); + pragma Inline (Index); + pragma Inline (Is_Open); + pragma Inline (Mode); + pragma Inline (Name); + pragma Inline (Open); + pragma Inline (Read); + pragma Inline (Reset); + pragma Inline (Set_Index); + pragma Inline (Size); + pragma Inline (Write); + +end Ada.Direct_IO; diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb new file mode 100644 index 00000000000..fd33b4f5fd2 --- /dev/null +++ b/gcc/ada/a-dynpri.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.25 $ +-- -- +-- Copyright (C) 1991-2001 Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Task_Identification; +-- used for Task_Id +-- Current_Task +-- Null_Task_Id +-- Is_Terminated + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock +-- Set_Priority +-- Wakeup +-- Self + +with System.Tasking; +-- used for Task_ID + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.Tasking.Initialization; +-- used for Defer/Undefer_Abort + +with Unchecked_Conversion; + +package body Ada.Dynamic_Priorities is + + use System.Tasking; + use Ada.Exceptions; + + function Convert_Ids is new + Unchecked_Conversion + (Task_Identification.Task_Id, System.Tasking.Task_ID); + + ------------------ + -- Get_Priority -- + ------------------ + + -- Inquire base priority of a task + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return System.Any_Priority is + + Target : constant Task_ID := Convert_Ids (T); + Error_Message : constant String := "Trying to get the priority of a "; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + Raise_Exception (Program_Error'Identity, + Error_Message & "null task"); + end if; + + if Task_Identification.Is_Terminated (T) then + Raise_Exception (Tasking_Error'Identity, + Error_Message & "null task"); + end if; + + return Target.Common.Base_Priority; + end Get_Priority; + + ------------------ + -- Set_Priority -- + ------------------ + + -- Change base priority of a task dynamically + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant Task_ID := Convert_Ids (T); + Self_ID : constant Task_ID := System.Task_Primitives.Operations.Self; + Error_Message : constant String := "Trying to set the priority of a "; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + Raise_Exception (Program_Error'Identity, + Error_Message & "null task"); + end if; + + if Task_Identification.Is_Terminated (T) then + Raise_Exception (Tasking_Error'Identity, + Error_Message & "terminated task"); + end if; + + System.Tasking.Initialization.Defer_Abort (Self_ID); + System.Task_Primitives.Operations.Write_Lock (Target); + + if Self_ID = Target then + Target.Common.Base_Priority := Priority; + System.Task_Primitives.Operations.Set_Priority (Target, Priority); + System.Task_Primitives.Operations.Unlock (Target); + System.Task_Primitives.Operations.Yield; + -- Yield is needed to enforce FIFO task dispatching. + -- LL Set_Priority is made while holding the RTS lock so that + -- it is inheriting high priority until it release all the RTS + -- locks. + -- If this is used in a system where Ceiling Locking is + -- not enforced we may end up getting two Yield effects. + else + Target.New_Base_Priority := Priority; + Target.Pending_Priority_Change := True; + Target.Pending_Action := True; + + System.Task_Primitives.Operations.Wakeup + (Target, Target.Common.State); + -- If the task is suspended, wake it up to perform the change. + -- check for ceiling violations ??? + System.Task_Primitives.Operations.Unlock (Target); + + end if; + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + end Set_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-dynpri.ads b/gcc/ada/a-dynpri.ads new file mode 100644 index 00000000000..208d5336c8d --- /dev/null +++ b/gcc/ada/a-dynpri.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Task_Identification; + +package Ada.Dynamic_Priorities is + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return System.Any_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-einuoc.adb b/gcc/ada/a-einuoc.adb new file mode 100644 index 00000000000..711352cb057 --- /dev/null +++ b/gcc/ada/a-einuoc.adb @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNAT-specific child function of Ada.Exceptions. It provides +-- clearly missing functionality for its parent package, and most reasonably +-- would simply be an added function to that package, but this change cannot +-- be made in a conforming manner. + +function Ada.Exceptions.Is_Null_Occurrence + (X : Exception_Occurrence) + return Boolean +is +begin + -- The null exception is uniquely identified by the fact that the Id + -- value is null. No other exception occurrence can have a null Id. + + if X.Id = Null_Id then + return True; + else + return False; + end if; +end Ada.Exceptions.Is_Null_Occurrence; diff --git a/gcc/ada/a-einuoc.ads b/gcc/ada/a-einuoc.ads new file mode 100644 index 00000000000..80400fc942f --- /dev/null +++ b/gcc/ada/a-einuoc.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNAT-specific child function of Ada.Exceptions. It provides +-- clearly missing functionality for its parent package, and most reasonably +-- would simply be an added function to that package, but this change cannot +-- be made in a conforming manner. + +function Ada.Exceptions.Is_Null_Occurrence + (X : Exception_Occurrence) + return Boolean; +-- This function yields True if X is Null_Occurrence, and False otherwise diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb new file mode 100644 index 00000000000..e3228d7d31a --- /dev/null +++ b/gcc/ada/a-except.adb @@ -0,0 +1,1980 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads new file mode 100644 index 00000000000..ff9a135e22b --- /dev/null +++ b/gcc/ada/a-except.ads @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.50 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with ourself. + +with System; +with System.Standard_Library; + +package Ada.Exceptions is + + type Exception_Id is private; + Null_Id : constant Exception_Id; + + type Exception_Occurrence is limited private; + type Exception_Occurrence_Access is access all Exception_Occurrence; + + Null_Occurrence : constant Exception_Occurrence; + + function Exception_Name (X : Exception_Occurrence) return String; + -- Same as Exception_Name (Exception_Identity (X)) + + function Exception_Name (Id : Exception_Id) return String; + + procedure Raise_Exception (E : Exception_Id; Message : String := ""); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Raise_Exception does return + -- if given the null exception. However we do special case the name in + -- the test in the compiler for issuing a warning for a missing return + -- after this call. Program_Error seems reasonable enough in such a case. + -- See also the routine Raise_Exception_Always in the private part. + + function Exception_Message (X : Exception_Occurrence) return String; + + procedure Reraise_Occurrence (X : Exception_Occurrence); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Reraise_Occurrence does return + -- if the argument is the null exception occurrence. See also procedure + -- Reraise_Occurrence_Always in the private part of this package. + + function Exception_Identity (X : Exception_Occurrence) return Exception_Id; + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by an ASCII.CR/ASCII.LF sequence. + -- The nnnn is the partition Id given as decimal digits. + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + -- Note on ordering: the compiler uses the Save_Occurrence procedure, but + -- not the function from Rtsfind, so it is important that the procedure + -- come first, since Rtsfind finds the first matching entity. + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + + function Save_Occurrence + (Source : Exception_Occurrence) + return Exception_Occurrence_Access; + +private + package SSL renames System.Standard_Library; + + subtype EOA is Exception_Occurrence_Access; + + Exception_Msg_Max_Length : constant := 200; + + ------------------ + -- Exception_Id -- + ------------------ + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call + -- addresses when propagating an exception (also traceback table) + -- Values of this type are created by using Label'Address or + -- extracted from machine states using Get_Code_Loc. + + Null_Loc : constant Code_Loc := System.Null_Address; + -- Null code location, used to flag outer level frame + + type Exception_Id is new SSL.Exception_Data_Ptr; + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); + -- Functions for implementing Exception_Id stream attributes + + Null_Id : constant Exception_Id := null; + + ------------------------- + -- Private Subprograms -- + ------------------------- + + function Current_Target_Exception return Exception_Occurrence; + pragma Export + (Ada, Current_Target_Exception, + "__gnat_current_target_exception"); + -- This routine should return the current raised exception on targets + -- which have built-in exception handling such as the Java Virtual + -- Machine. For other targets this routine is simply ignored. Currently, + -- only JGNAT uses this. See 4jexcept.ads for details. The pragma Export + -- allows this routine to be accessed elsewhere in the run-time, even + -- though it is in the private part of this package (it is not allowed + -- to be in the visible part, since this is set by the reference manual). + + function Exception_Name_Simple (X : Exception_Occurrence) return String; + -- Like Exception_Name, but returns the simple non-qualified name of + -- the exception. This is used to implement the Exception_Name function + -- in Current_Exceptions (the DEC compatible unit). It is called from + -- the compiler generated code (using Rtsfind, which does not respect + -- the private barrier, so we can place this function in the private + -- part where the compiler can find it, but the spec is unchanged.) + + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception_Always); + pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); + -- This differs from Raise_Exception only in that the caller has determined + -- that for sure the parameter E is not null, and that therefore the call + -- to this procedure cannot return. The expander converts Raise_Exception + -- calls to Raise_Exception_Always if it can determine this is the case. + -- The Export allows this routine to be accessed from Pure units. + + procedure Raise_No_Msg (E : Exception_Id); + pragma No_Return (Raise_No_Msg); + -- Raises an exception with no message with given exception id value. + -- Abort is deferred before the raise call. + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : SSL.Big_String_Ptr); + pragma Export + (Ada, Raise_From_Signal_Handler, + "ada__exceptions__raise_from_signal_handler"); + pragma No_Return (Raise_From_Signal_Handler); + -- This routine is used to raise an exception from a signal handler. + -- The signal handler has already stored the machine state (i.e. the + -- state that corresponds to the location at which the signal was + -- raised). E is the Exception_Id specifying what exception is being + -- raised, and M is a pointer to a null-terminated string which is the + -- message to be raised. Note that this routine never returns, so it is + -- permissible to simply jump to this routine, rather than call it. This + -- may be appropriate for systems where the right way to get out of a + -- signal handler is to alter the PC value in the machine state or in + -- some other way ask the operating system to return here rather than + -- to the original location. + + procedure Raise_With_C_Msg + (E : Exception_Id; + M : SSL.Big_String_Ptr); + pragma Export (Ada, Raise_With_C_Msg, "ada__exceptions__raise_with_c_msg"); + pragma No_Return (Raise_With_C_Msg); + -- Raises an exception with with given exception id value and message. + -- M is a null terminated string with the message to be raised. Abort + -- is deferred before the raise call. + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_Always); + -- This differs from Raise_Occurrence only in that the caller guarantees + -- that for sure the parameter X is not the null occurrence, and that + -- therefore this procedure cannot return. The expander uses this routine + -- in the translation of a raise statement with no parameter (reraise). + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_No_Defer); + -- Exactly like Reraise_Occurrence, except that abort is not deferred + -- before the call and the parameter X is known not to be the null + -- occurrence. This is used in generated code when it is known + -- that abort is already deferred. + + procedure SDP_Table_Build + (SDP_Addresses : System.Address; + SDP_Count : Natural; + Elab_Addresses : System.Address; + Elab_Addr_Count : Natural); + pragma Export (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); + -- This is the routine that is called to build and sort the list of + -- subprogram descriptor pointers. In the normal case it is called + -- once at the start of execution, but it can also be called as part + -- of the explicit initialization routine (adainit) when there is no + -- Ada main program. In particular, in the case where multiple Ada + -- libraries are present, this routine can be called more than once + -- for each library, in which case it augments the previously set + -- table with the new entries specified by the parameters. + -- + -- SDP_Addresses Address of the start of the list of addresses of + -- __gnat_unit_name__SDP values constructed for each + -- unit, (see System.Exceptions). + -- + -- SDP_Count Number of entries in SDP_Addresses + -- + -- Elab_Addresses Address of the start of a list of addresses of + -- generated Ada elaboration routines, as well as + -- one extra entry for the generated main program. + -- These are used to generate the dummy SDP's that + -- mark the outer scope. + -- + -- Elab_Addr_Count Number of entries in Elab_Addresses + + procedure Break_Start; + pragma Export (C, Break_Start, "__gnat_break_start"); + -- This is a dummy procedure that is called at the start of execution. + -- Its sole purpose is to provide a well defined point for the placement + -- of a main program breakpoint. We put the routine in Ada.Exceptions so + -- that the standard mechanism of always stepping up from breakpoints + -- within Ada.Exceptions leaves us sitting in the main program. + + ----------------------- + -- Polling Interface -- + ----------------------- + + -- The GNAT compiler has an option to generate polling calls to the Poll + -- routine in this package. Specifying the -gnatP option for a compilation + -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram + -- entry and on every iteration of a loop, thus avoiding the possibility of + -- a case of unbounded time between calls. + + -- This polling interface may be used for instrumentation or debugging + -- purposes (e.g. implementing watchpoints in software or in the debugger). + + -- In the GNAT technology itself, this interface is used to implement + -- immediate aynschronous transfer of control and immediate abort on + -- targets which do not provide for one thread interrupting another. + + -- Note: this used to be in a separate unit called System.Poll, but that + -- caused horrible circular elaboration problems between System.Poll and + -- Ada.Exceptions. One way of solving such circularities is unification! + + procedure Poll; + -- Check for asynchronous abort. Note that we do not inline the body. + -- This makes the interface more useful for debugging purposes. + + -------------------------- + -- Exception_Occurrence -- + -------------------------- + + Max_Tracebacks : constant := 50; + -- Maximum number of trace backs stored in exception occurrence + + type Tracebacks_Array is array (1 .. Max_Tracebacks) of Code_Loc; + -- Traceback array stored in exception occurrence + + type Exception_Occurrence is record + Id : Exception_Id; + -- Exception_Identity for this exception occurrence + -- WARNING System.System.Finalization_Implementation.Finalize_List + -- relies on the fact that this field is always first in the exception + -- occurrence + + Msg_Length : Natural := 0; + -- Length of message (zero = no message) + + Msg : String (1 .. Exception_Msg_Max_Length); + -- Characters of message + + Cleanup_Flag : Boolean; + -- The cleanup flag is normally False, it is set True for an exception + -- occurrence passed to a cleanup routine, and will still be set True + -- when the cleanup routine does a Reraise_Occurrence call using this + -- exception occurrence. This is used to avoid recording a bogus trace + -- back entry from this reraise call. + + Exception_Raised : Boolean := False; + -- Set to true to indicate that this exception occurrence has actually + -- been raised. When an exception occurrence is first created, this is + -- set to False, then when it is processed by Raise_Current_Exception, + -- it is set to True. If Raise_Current_Exception is used to raise an + -- exception for which this flag is already True, then it knows that + -- it is dealing with the reraise case (which is useful to distinguish + -- for exception tracing purposes). + + Pid : Natural; + -- Partition_Id for partition raising exception + + Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; + -- Number of traceback entries stored + + Tracebacks : Tracebacks_Array; + -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + end record; + + function "=" (Left, Right : Exception_Occurrence) return Boolean + is abstract; + -- Don't allow comparison on exception occurrences, we should not need + -- this, and it would not work right, because of the Msg and Tracebacks + -- fields which have unused entries not copied by Save_Occurrence. + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); + -- Functions for implementing Exception_Occurrence stream attributes + + Null_Occurrence : constant Exception_Occurrence := ( + Id => Null_Id, + Msg_Length => 0, + Msg => (others => ' '), + Cleanup_Flag => False, + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => Null_Loc)); + +end Ada.Exceptions; diff --git a/gcc/ada/a-excpol.adb b/gcc/ada/a-excpol.adb new file mode 100644 index 00000000000..18e1671c2aa --- /dev/null +++ b/gcc/ada/a-excpol.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- -- +-- B o d y -- +-- (dummy version where polling is not used) -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + null; +end Poll; diff --git a/gcc/ada/a-exctra.adb b/gcc/ada/a-exctra.adb new file mode 100644 index 00000000000..af6953e43d2 --- /dev/null +++ b/gcc/ada/a-exctra.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Exceptions.Traceback is + + function Tracebacks + (E : Exception_Occurrence) + return GNAT.Traceback.Tracebacks_Array + is + begin + return + GNAT.Traceback.Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks)); + end Tracebacks; + +end Ada.Exceptions.Traceback; diff --git a/gcc/ada/a-exctra.ads b/gcc/ada/a-exctra.ads new file mode 100644 index 00000000000..05fc554bc4d --- /dev/null +++ b/gcc/ada/a-exctra.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package is part of the support for tracebacks on exceptions. It is +-- used ONLY from GNAT.Traceback.Symbolic and is provided to get access to +-- the tracebacks in an exception occurrence. It may not be used directly +-- from the Ada hierarchy (since it references GNAT.Traceback). + +with GNAT.Traceback; + +package Ada.Exceptions.Traceback is + + function Tracebacks + (E : Exception_Occurrence) + return GNAT.Traceback.Tracebacks_Array; + -- This function extracts the traceback information from an exception + -- occurrence, and returns it formatted in the manner required for + -- processing in GNAT.Traceback. See g-traceb.ads for details. + +end Ada.Exceptions.Traceback; diff --git a/gcc/ada/a-filico.adb b/gcc/ada/a-filico.adb new file mode 100644 index 00000000000..1bc95e989e2 --- /dev/null +++ b/gcc/ada/a-filico.adb @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . L I S T _ F I N A L I Z A T I O N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Implementation; +package body Ada.Finalization.List_Controller is + + package SFI renames System.Finalization_Implementation; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out List_Controller) is + use type SFR.Finalizable_Ptr; + + Last_Ptr : constant SFR.Finalizable_Ptr := Object.Last'Unchecked_Access; + + begin + while Object.First.Next /= Last_Ptr loop + SFI.Finalize_One (Object.First.Next.all); + end loop; + end Finalize; + + procedure Finalize (Object : in out Simple_List_Controller) is + begin + SFI.Finalize_List (Object.F); + Object.F := null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out List_Controller) is + begin + Object.F := Object.First'Unchecked_Access; + Object.First.Next := Object.Last 'Unchecked_Access; + Object.Last.Prev := Object.First'Unchecked_Access; + end Initialize; + +end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-filico.ads b/gcc/ada/a-filico.ads new file mode 100644 index 00000000000..506d20376f4 --- /dev/null +++ b/gcc/ada/a-filico.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N . L I S T _ C O N T R O L L E R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Root; +package Ada.Finalization.List_Controller is +pragma Elaborate_Body (List_Controller); + + package SFR renames System.Finalization_Root; + + ---------------------------- + -- Simple_List_Controller -- + ---------------------------- + + type Simple_List_Controller is new Ada.Finalization.Limited_Controlled + with record + F : SFR.Finalizable_Ptr; + end record; + -- Used by the compiler to carry a list of temporary objects that + -- needs to be finalized after having being used. This list is + -- embedded in a controlled type so that if an exception is raised + -- while those temporaries are still in use, they will be reclaimed + -- by the normal finalization mechanism. + + procedure Finalize (Object : in out Simple_List_Controller); + + --------------------- + -- List_Controller -- + --------------------- + + -- Management of a bidirectional linked heterogenous list of + -- dynamically Allocated objects. To simplify the management of the + -- linked list, the First and Last elements are statically part of the + -- original List controller: + -- + -- +------------+ + -- | --|-->-- + -- +------------+ + -- |--<-- | record with ctrl components + -- |------------| +----------+ + -- +--|-- L | | | + -- | |------------| | | + -- | |+--------+ | +--------+ |+--------+| + -- +->|| prev | F|---<---|-- |----<---||-- ||--<--+ + -- ||--------| i| |--------| ||--------|| | + -- || next | r|--->---| --|---->---|| --||--------+ + -- |+--------+ s| |--------| ||--------|| | | + -- | t| | ctrl | || || | | + -- | | : : |+--------+| | | + -- | | : object : |rec | | | + -- | | : : |controller| | | + -- | | | | | | | v + -- |+--------+ | +--------+ +----------+ | | + -- || prev -|-L|--------------------->--------------------+ | + -- ||--------| a| | + -- || next | s|-------------------<-------------------------+ + -- |+--------+ t| + -- | | + -- +------------+ + + type List_Controller is new Ada.Finalization.Limited_Controlled + with record + F : SFR.Finalizable_Ptr; + First, + Last : aliased SFR.Root_Controlled; + end record; + -- Controls the chains of dynamically allocated controlled + -- objects makes sure that they get finalized upon exit from + -- the access type that defined them + + procedure Initialize (Object : in out List_Controller); + procedure Finalize (Object : in out List_Controller); + +end Ada.Finalization.List_Controller; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb new file mode 100644 index 00000000000..cb04381d778 --- /dev/null +++ b/gcc/ada/a-finali.adb @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Root; use System.Finalization_Root; + +package body Ada.Finalization is + + --------- + -- "=" -- + --------- + + function "=" (A, B : Controlled) return Boolean is + begin + return Empty_Root_Controlled (A) = Empty_Root_Controlled (B); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Controlled) is + begin + null; + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Controlled) is + begin + null; + end Finalize; + + procedure Finalize (Object : in out Limited_Controlled) is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Controlled) is + begin + null; + end Initialize; + + procedure Initialize (Object : in out Limited_Controlled) is + begin + null; + end Initialize; + +end Ada.Finalization; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads new file mode 100644 index 00000000000..5d8dd137db3 --- /dev/null +++ b/gcc/ada/a-finali.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Finalization_Root; + +package Ada.Finalization is +pragma Preelaborate (Finalization); + + type Controlled is abstract tagged private; + + procedure Initialize (Object : in out Controlled); + procedure Adjust (Object : in out Controlled); + procedure Finalize (Object : in out Controlled); + + type Limited_Controlled is abstract tagged limited private; + + procedure Initialize (Object : in out Limited_Controlled); + procedure Finalize (Object : in out Limited_Controlled); + +private + package SFR renames System.Finalization_Root; + + type Controlled is abstract new SFR.Root_Controlled with null record; + + function "=" (A, B : Controlled) return Boolean; + -- Need to be defined explictly because we don't want to compare the + -- hidden pointers + + type Limited_Controlled is + abstract new SFR.Root_Controlled with null record; + +end Ada.Finalization; diff --git a/gcc/ada/a-flteio.ads b/gcc/ada/a-flteio.ads new file mode 100644 index 00000000000..8c5895381fd --- /dev/null +++ b/gcc/ada/a-flteio.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +pragma Elaborate_All (Ada.Text_IO); + +package Ada.Float_Text_IO is + new Ada.Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-fwteio.ads b/gcc/ada/a-fwteio.ads new file mode 100644 index 00000000000..0085b10f4ce --- /dev/null +++ b/gcc/ada/a-fwteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-inteio.ads b/gcc/ada/a-inteio.ads new file mode 100644 index 00000000000..3b068a987eb --- /dev/null +++ b/gcc/ada/a-inteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-interr.adb b/gcc/ada/a-interr.adb new file mode 100644 index 00000000000..d5ec16d7e66 --- /dev/null +++ b/gcc/ada/a-interr.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1991-2001 Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupts; +-- used for Interrupt_ID +-- Parameterless_Handler +-- Is_Reserved +-- Is_Handler_Attached +-- Current_Handler +-- Attach_Handler +-- Exchange_Handler +-- Detach_Handler +-- Reference + +with Unchecked_Conversion; + +package body Ada.Interrupts is + + package SI renames System.Interrupts; + + function To_System is new Unchecked_Conversion + (Parameterless_Handler, SI.Parameterless_Handler); + + function To_Ada is new Unchecked_Conversion + (SI.Parameterless_Handler, Parameterless_Handler); + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + begin + SI.Attach_Handler + (To_System (New_Handler), SI.Interrupt_ID (Interrupt), False); + end Attach_Handler; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) + return Parameterless_Handler + is + begin + return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt))); + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler (Interrupt : in Interrupt_ID) is + begin + SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False); + end Detach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + H : SI.Parameterless_Handler; + + begin + SI.Exchange_Handler + (H, To_System (New_Handler), + SI.Interrupt_ID (Interrupt), False); + Old_Handler := To_Ada (H); + end Exchange_Handler; + + ----------------- + -- Is_Attached -- + ----------------- + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Handler_Attached (SI.Interrupt_ID (Interrupt)); + end Is_Attached; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Reserved (SI.Interrupt_ID (Interrupt)); + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + return SI.Reference (SI.Interrupt_ID (Interrupt)); + end Reference; + +end Ada.Interrupts; diff --git a/gcc/ada/a-interr.ads b/gcc/ada/a-interr.ads new file mode 100644 index 00000000000..e2ca5367bb4 --- /dev/null +++ b/gcc/ada/a-interr.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupts; +-- used for Ada_Interrupt_ID. + +package Ada.Interrupts is + + type Interrupt_ID is new System.Interrupts.Ada_Interrupt_ID; + + type Parameterless_Handler is access protected procedure; + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Current_Handler + (Interrupt : Interrupt_ID) + return Parameterless_Handler; + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID); + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID); + + procedure Detach_Handler (Interrupt : Interrupt_ID); + + function Reference (Interrupt : Interrupt_ID) return System.Address; + +private + pragma Inline (Is_Reserved); + pragma Inline (Is_Attached); + pragma Inline (Current_Handler); + pragma Inline (Attach_Handler); + pragma Inline (Detach_Handler); + pragma Inline (Exchange_Handler); +end Ada.Interrupts; diff --git a/gcc/ada/a-intnam.ads b/gcc/ada/a-intnam.ads new file mode 100644 index 00000000000..5a1b145ef2e --- /dev/null +++ b/gcc/ada/a-intnam.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- The standard implementation of this spec contains only dummy interrupt +-- names. These dummy entries permit checking out code for correctness of +-- semantics, even if interrupts are not supported. + +-- For specific implementations that fully support interrupts, this package +-- spec is replaced by an implementation dependent version that defines the +-- interrupts available on the system. + +package Ada.Interrupts.Names is + + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; + DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intsig.adb b/gcc/ada/a-intsig.adb new file mode 100644 index 00000000000..f4448a4bac5 --- /dev/null +++ b/gcc/ada/a-intsig.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . S I G N A L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +with System.Interrupt_Management.Operations; +package body Ada.Interrupts.Signal is + + ------------------------- + -- Generate_Interrupt -- + ------------------------- + + procedure Generate_Interrupt (Interrupt : Interrupt_ID) is + begin + System.Interrupt_Management.Operations.Interrupt_Self_Process + (System.Interrupt_Management.Interrupt_ID (Interrupt)); + end Generate_Interrupt; +end Ada.Interrupts.Signal; diff --git a/gcc/ada/a-intsig.ads b/gcc/ada/a-intsig.ads new file mode 100644 index 00000000000..42f86f8f617 --- /dev/null +++ b/gcc/ada/a-intsig.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . S I G N A L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This package encapsulates the procedures for generating interrupts +-- by user programs and avoids importing low level children of System +-- (e.g. System.Interrupt_Management.Operations), or defining an interface +-- to complex system calls. +-- +package Ada.Interrupts.Signal is + + procedure Generate_Interrupt (Interrupt : Interrupt_ID); + -- Generate Interrupt at the process level + +end Ada.Interrupts.Signal; diff --git a/gcc/ada/a-ioexce.ads b/gcc/ada/a-ioexce.ads new file mode 100644 index 00000000000..58b9e1b89b1 --- /dev/null +++ b/gcc/ada/a-ioexce.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.IO_Exceptions is +pragma Pure (IO_Exceptions); + + Status_Error : exception; + Mode_Error : exception; + Name_Error : exception; + Use_Error : exception; + Device_Error : exception; + End_Error : exception; + Data_Error : exception; + Layout_Error : exception; + +end Ada.IO_Exceptions; diff --git a/gcc/ada/a-iwteio.ads b/gcc/ada/a-iwteio.ads new file mode 100644 index 00000000000..998a49076d5 --- /dev/null +++ b/gcc/ada/a-iwteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-lfteio.ads b/gcc/ada/a-lfteio.ads new file mode 100644 index 00000000000..d34b5b2a25c --- /dev/null +++ b/gcc/ada/a-lfteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-lfwtio.ads b/gcc/ada/a-lfwtio.ads new file mode 100644 index 00000000000..ce15d2e90fa --- /dev/null +++ b/gcc/ada/a-lfwtio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-liteio.ads b/gcc/ada/a-liteio.ads new file mode 100644 index 00000000000..85ef631a509 --- /dev/null +++ b/gcc/ada/a-liteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-liwtio.ads b/gcc/ada/a-liwtio.ads new file mode 100644 index 00000000000..5df1d99be4f --- /dev/null +++ b/gcc/ada/a-liwtio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-llftio.ads b/gcc/ada/a-llftio.ads new file mode 100644 index 00000000000..985ea559702 --- /dev/null +++ b/gcc/ada/a-llftio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llfwti.ads b/gcc/ada/a-llfwti.ads new file mode 100644 index 00000000000..46a4ef79780 --- /dev/null +++ b/gcc/ada/a-llfwti.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llitio.ads b/gcc/ada/a-llitio.ads new file mode 100644 index 00000000000..3f7ebfd83be --- /dev/null +++ b/gcc/ada/a-llitio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-lliwti.ads b/gcc/ada/a-lliwti.ads new file mode 100644 index 00000000000..e6f2980342d --- /dev/null +++ b/gcc/ada/a-lliwti.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-ncelfu.ads b/gcc/ada/a-ncelfu.ads new file mode 100644 index 00000000000..089ee09a66d --- /dev/null +++ b/gcc/ada/a-ncelfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Complex_Types); diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb new file mode 100644 index 00000000000..1a19e0599cd --- /dev/null +++ b/gcc/ada/a-ngcefu.adb @@ -0,0 +1,709 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package body Ada.Numerics.Generic_Complex_Elementary_Functions is + + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real'Base); + use Elementary_Functions; + + PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; + PI_2 : constant := PI / 2.0; + Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + + subtype T is Real'Base; + + Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa); + Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); + Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1); + Root_Root_Epsilon : constant T := Sqrt_Two ** + ((1 - T'Model_Mantissa) / 2); + Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0; + + Complex_Zero : constant Complex := (0.0, 0.0); + Complex_One : constant Complex := (1.0, 0.0); + Complex_I : constant Complex := (0.0, 1.0); + Half_Pi : constant Complex := (PI_2, 0.0); + + -------- + -- ** -- + -------- + + function "**" (Left : Complex; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 + and then Im (Right) = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Re (Right) < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = (0.0, 0.0) then + return Complex_One; + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return 1.0 + Right; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + function "**" (Left : Real'Base; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then + raise Argument_Error; + + elsif Left = 0.0 and then Re (Right) < 0.0 then + raise Constraint_Error; + + elsif Left = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return Complex_One; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + else + return Exp (Log (Left) * Right); + end if; + end "**"; + + function "**" (Left : Complex; Right : Real'Base) return Complex is + begin + if Right = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Right < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = 0.0 then + return Complex_One; + + elsif Right = 1.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + ------------ + -- Arccos -- + ------------ + + function Arccos (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) + + Complex_I * Sqrt ((1.0 - X) / 2.0)); + end if; + + Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X)); + + if Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arccos; + + ------------- + -- Arccosh -- + ------------- + + function Arccosh (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X)); + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); + + else + Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) + + Sqrt ((X - 1.0) / 2.0)); + end if; + + if Re (Result) <= 0.0 then + Result := -Result; + end if; + + return Result; + end Arccosh; + + ------------ + -- Arccot -- + ------------ + + function Arccot (X : Complex) return Complex is + Xt : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + Xt := Complex_One / X; + + if Re (X) < 0.0 then + Set_Re (Xt, PI - Re (Xt)); + return Xt; + else + return Xt; + end if; + end if; + + Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0; + + if Re (Xt) < 0.0 then + Xt := PI + Xt; + end if; + + return Xt; + end Arccot; + + -------------- + -- Arctcoth -- + -------------- + + function Arccoth (X : Complex) return Complex is + R : Complex; + + begin + if X = (0.0, 0.0) then + return Compose_From_Cartesian (0.0, PI_2); + + elsif abs Re (X) < Square_Root_Epsilon + and then abs Im (X) < Square_Root_Epsilon + then + return PI_2 * Complex_I + X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + if Im (X) > 0.0 then + return (0.0, 0.0); + else + return PI * Complex_I; + end if; + + elsif Im (X) = 0.0 and then Re (X) = 1.0 then + raise Constraint_Error; + + elsif Im (X) = 0.0 and then Re (X) = -1.0 then + raise Constraint_Error; + end if; + + begin + R := Log ((1.0 + X) / (X - 1.0)) / 2.0; + + exception + when Constraint_Error => + R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0; + end; + + if Im (R) < 0.0 then + Set_Im (R, PI + Im (R)); + end if; + + if Re (X) = 0.0 then + Set_Re (R, Re (X)); + end if; + + return R; + end Arccoth; + + ------------ + -- Arcsin -- + ------------ + + function Arcsin (X : Complex) return Complex is + Result : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I)); + + if Im (Result) > PI_2 then + Set_Im (Result, PI - Im (X)); + + elsif Im (Result) < -PI_2 then + Set_Im (Result, -(PI + Im (X))); + end if; + end if; + + Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + + elsif Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsin; + + ------------- + -- Arcsinh -- + ------------- + + function Arcsinh (X : Complex) return Complex is + Result : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); -- may have wrong sign + + if (Re (X) < 0.0 and Re (Result) > 0.0) + or else (Re (X) > 0.0 and Re (Result) < 0.0) + then + Set_Re (Result, -Re (Result)); + end if; + + return Result; + end if; + + Result := Log (X + Sqrt (1.0 + X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + elsif Im (X) = 0.0 then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsinh; + + ------------ + -- Arctan -- + ------------ + + function Arctan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return -Complex_I * (Log (1.0 + Complex_I * X) + - Log (1.0 - Complex_I * X)) / 2.0; + end if; + end Arctan; + + ------------- + -- Arctanh -- + ------------- + + function Arctanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + else + return (Log (1.0 + X) - Log (1.0 - X)) / 2.0; + end if; + end Arctanh; + + --------- + -- Cos -- + --------- + + function Cos (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cos (Re (X)) * Cosh (Im (X)), + -Sin (Re (X)) * Sinh (Im (X))); + end Cos; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cosh (Re (X)) * Cos (Im (X)), + Sinh (Re (X)) * Sin (Im (X))); + end Cosh; + + --------- + -- Cot -- + --------- + + function Cot (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return -Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return Complex_I; + end if; + + return Cos (X) / Sin (X); + end Cot; + + ---------- + -- Coth -- + ---------- + + function Coth (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Cosh (X) / Sinh (X); + end if; + end Coth; + + --------- + -- Exp -- + --------- + + function Exp (X : Complex) return Complex is + EXP_RE_X : Real'Base := Exp (Re (X)); + + begin + return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), + EXP_RE_X * Sin (Im (X))); + end Exp; + + + function Exp (X : Imaginary) return Complex is + ImX : Real'Base := Im (X); + + begin + return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); + end Exp; + + --------- + -- Log -- + --------- + + function Log (X : Complex) return Complex is + ReX : Real'Base; + ImX : Real'Base; + Z : Complex; + + begin + if Re (X) = 0.0 and then Im (X) = 0.0 then + raise Constraint_Error; + + elsif abs (1.0 - Re (X)) < Root_Root_Epsilon + and then abs Im (X) < Root_Root_Epsilon + then + Z := X; + Set_Re (Z, Re (Z) - 1.0); + + return (1.0 - (1.0 / 2.0 - + (1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z; + end if; + + begin + ReX := Log (Modulus (X)); + + exception + when Constraint_Error => + ReX := Log (Modulus (X / 2.0)) - Log_Two; + end; + + ImX := Arctan (Im (X), Re (X)); + + if ImX > PI then + ImX := ImX - 2.0 * PI; + end if; + + return Compose_From_Cartesian (ReX, ImX); + end Log; + + --------- + -- Sin -- + --------- + + function Sin (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon then + return X; + end if; + + return + Compose_From_Cartesian + (Sin (Re (X)) * Cosh (Im (X)), + Cos (Re (X)) * Sinh (Im (X))); + end Sin; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)), + Cosh (Re (X)) * Sin (Im (X))); + end if; + end Sinh; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Complex) return Complex is + ReX : constant Real'Base := Re (X); + ImX : constant Real'Base := Im (X); + XR : constant Real'Base := abs Re (X); + YR : constant Real'Base := abs Im (X); + R : Real'Base; + R_X : Real'Base; + R_Y : Real'Base; + + begin + -- Deal with pure real case, see (RM G.1.2(39)) + + if ImX = 0.0 then + if ReX > 0.0 then + return + Compose_From_Cartesian + (Sqrt (ReX), 0.0); + + elsif ReX = 0.0 then + return X; + + else + return + Compose_From_Cartesian + (0.0, Real'Copy_Sign (Sqrt (-ReX), ImX)); + end if; + + elsif ReX = 0.0 then + R_X := Sqrt (YR / 2.0); + + if ImX > 0.0 then + return Compose_From_Cartesian (R_X, R_X); + else + return Compose_From_Cartesian (R_X, -R_X); + end if; + + else + R := Sqrt (XR ** 2 + YR ** 2); + + -- If the square of the modulus overflows, try rescaling the + -- real and imaginary parts. We cannot depend on an exception + -- being raised on all targets. + + if R > Real'Base'Last then + raise Constraint_Error; + end if; + + -- We are solving the system + + -- XR = R_X ** 2 - Y_R ** 2 (1) + -- YR = 2.0 * R_X * R_Y (2) + -- + -- The symmetric solution involves square roots for both R_X and + -- R_Y, but it is more accurate to use the square root with the + -- larger argument for either R_X or R_Y, and equation (2) for the + -- other. + + if ReX < 0.0 then + R_Y := Sqrt (0.5 * (R - ReX)); + R_X := YR / (2.0 * R_Y); + + else + R_X := Sqrt (0.5 * (R + ReX)); + R_Y := YR / (2.0 * R_X); + end if; + end if; + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + return Compose_From_Cartesian (R_X, R_Y); + + exception + when Constraint_Error => + + -- Rescale and try again. + + R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0))); + R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0)); + R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0)); + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + + return Compose_From_Cartesian (R_X, R_Y); + end Sqrt; + + --------- + -- Tan -- + --------- + + function Tan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return -Complex_I; + + else + return Sin (X) / Cos (X); + end if; + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Sinh (X) / Cosh (X); + end if; + end Tanh; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcefu.ads b/gcc/ada/a-ngcefu.ads new file mode 100644 index 00000000000..77dc407df5f --- /dev/null +++ b/gcc/ada/a-ngcefu.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + use Complex_Types; + +package Ada.Numerics.Generic_Complex_Elementary_Functions is + pragma Pure (Ada.Numerics.Generic_Complex_Elementary_Functions); + + function Sqrt (X : Complex) return Complex; + + function Log (X : Complex) return Complex; + + function Exp (X : Complex) return Complex; + function Exp (X : Imaginary) return Complex; + + function "**" (Left : Complex; Right : Complex) return Complex; + function "**" (Left : Complex; Right : Real'Base) return Complex; + function "**" (Left : Real'Base; Right : Complex) return Complex; + + function Sin (X : Complex) return Complex; + function Cos (X : Complex) return Complex; + function Tan (X : Complex) return Complex; + function Cot (X : Complex) return Complex; + + function Arcsin (X : Complex) return Complex; + function Arccos (X : Complex) return Complex; + function Arctan (X : Complex) return Complex; + function Arccot (X : Complex) return Complex; + + function Sinh (X : Complex) return Complex; + function Cosh (X : Complex) return Complex; + function Tanh (X : Complex) return Complex; + function Coth (X : Complex) return Complex; + + function Arcsinh (X : Complex) return Complex; + function Arccosh (X : Complex) return Complex; + function Arctanh (X : Complex) return Complex; + function Arccoth (X : Complex) return Complex; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb new file mode 100644 index 00000000000..df0b73ac54b --- /dev/null +++ b/gcc/ada/a-ngcoty.adb @@ -0,0 +1,667 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Aux; use Ada.Numerics.Aux; +package body Ada.Numerics.Generic_Complex_Types is + + subtype R is Real'Base; + + Two_Pi : constant R := R (2.0) * Pi; + Half_Pi : constant R := Pi / R (2.0); + + --------- + -- "*" -- + --------- + + function "*" (Left, Right : Complex) return Complex is + X : R; + Y : R; + + begin + X := Left.Re * Right.Re - Left.Im * Right.Im; + Y := Left.Re * Right.Im + Left.Im * Right.Re; + + -- If either component overflows, try to scale. + + if abs (X) > R'Last then + X := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0) + - R'(Left.Im / 2.0) * R'(Right.Im / 2.0)); + end if; + + if abs (Y) > R'Last then + Y := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0) + - R'(Left.Im / 2.0) * R'(Right.Re / 2.0)); + end if; + + return (X, Y); + end "*"; + + function "*" (Left, Right : Imaginary) return Real'Base is + begin + return -R (Left) * R (Right); + end "*"; + + function "*" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re * Right, Left.Im * Right); + end "*"; + + function "*" (Left : Real'Base; Right : Complex) return Complex is + begin + return (Left * Right.Re, Left * Right.Im); + end "*"; + + function "*" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right)); + end "*"; + + function "*" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re); + end "*"; + + function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is + begin + return Left * Imaginary (Right); + end "*"; + + function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is + begin + return Imaginary (Left * R (Right)); + end "*"; + + ---------- + -- "**" -- + ---------- + + function "**" (Left : Complex; Right : Integer) return Complex is + Result : Complex := (1.0, 0.0); + Factor : Complex := Left; + Exp : Integer := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. For positive exponents we + -- multiply the result by this factor, for negative exponents, we + -- divide by this factor. + + if Exp >= 0 then + + -- For a positive exponent, if we get a constraint error during + -- this loop, it is an overflow, and the constraint error will + -- simply be passed on to the caller. + + while Exp /= 0 loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Factor := Factor * Factor; + Exp := Exp / 2; + end loop; + + return Result; + + else -- Exp < 0 then + + -- For the negative exponent case, a constraint error during this + -- calculation happens if Factor gets too large, and the proper + -- response is to return 0.0, since what we essentially have is + -- 1.0 / infinity, and the closest model number will be zero. + + begin + + while Exp /= 0 loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Factor := Factor * Factor; + Exp := Exp / 2; + end loop; + + return R ' (1.0) / Result; + + exception + + when Constraint_Error => + return (0.0, 0.0); + end; + end if; + end "**"; + + function "**" (Left : Imaginary; Right : Integer) return Complex is + M : R := R (Left) ** Right; + begin + case Right mod 4 is + when 0 => return (M, 0.0); + when 1 => return (0.0, M); + when 2 => return (-M, 0.0); + when 3 => return (0.0, -M); + when others => raise Program_Error; + end case; + end "**"; + + --------- + -- "+" -- + --------- + + function "+" (Right : Complex) return Complex is + begin + return Right; + end "+"; + + function "+" (Left, Right : Complex) return Complex is + begin + return Complex'(Left.Re + Right.Re, Left.Im + Right.Im); + end "+"; + + function "+" (Right : Imaginary) return Imaginary is + begin + return Right; + end "+"; + + function "+" (Left, Right : Imaginary) return Imaginary is + begin + return Imaginary (R (Left) + R (Right)); + end "+"; + + function "+" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re + Right, Left.Im); + end "+"; + + function "+" (Left : Real'Base; Right : Complex) return Complex is + begin + return Complex'(Left + Right.Re, Right.Im); + end "+"; + + function "+" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(Left.Re, Left.Im + R (Right)); + end "+"; + + function "+" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(Right.Re, R (Left) + Right.Im); + end "+"; + + function "+" (Left : Imaginary; Right : Real'Base) return Complex is + begin + return Complex'(Right, R (Left)); + end "+"; + + function "+" (Left : Real'Base; Right : Imaginary) return Complex is + begin + return Complex'(Left, R (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Right : Complex) return Complex is + begin + return (-Right.Re, -Right.Im); + end "-"; + + function "-" (Left, Right : Complex) return Complex is + begin + return (Left.Re - Right.Re, Left.Im - Right.Im); + end "-"; + + function "-" (Right : Imaginary) return Imaginary is + begin + return Imaginary (-R (Right)); + end "-"; + + function "-" (Left, Right : Imaginary) return Imaginary is + begin + return Imaginary (R (Left) - R (Right)); + end "-"; + + function "-" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re - Right, Left.Im); + end "-"; + + function "-" (Left : Real'Base; Right : Complex) return Complex is + begin + return Complex'(Left - Right.Re, -Right.Im); + end "-"; + + function "-" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(Left.Re, Left.Im - R (Right)); + end "-"; + + function "-" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(-Right.Re, R (Left) - Right.Im); + end "-"; + + function "-" (Left : Imaginary; Right : Real'Base) return Complex is + begin + return Complex'(-Right, R (Left)); + end "-"; + + function "-" (Left : Real'Base; Right : Imaginary) return Complex is + begin + return Complex'(Left, -R (Right)); + end "-"; + + --------- + -- "/" -- + --------- + + function "/" (Left, Right : Complex) return Complex is + a : constant R := Left.Re; + b : constant R := Left.Im; + c : constant R := Right.Re; + d : constant R := Right.Im; + + begin + if c = 0.0 and then d = 0.0 then + raise Constraint_Error; + else + return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2), + Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2)); + end if; + end "/"; + + function "/" (Left, Right : Imaginary) return Real'Base is + begin + return R (Left) / R (Right); + end "/"; + + function "/" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re / Right, Left.Im / Right); + end "/"; + + function "/" (Left : Real'Base; Right : Complex) return Complex is + a : constant R := Left; + c : constant R := Right.Re; + d : constant R := Right.Im; + begin + return Complex'(Re => (a * c) / (c ** 2 + d ** 2), + Im => -(a * d) / (c ** 2 + d ** 2)); + end "/"; + + function "/" (Left : Complex; Right : Imaginary) return Complex is + a : constant R := Left.Re; + b : constant R := Left.Im; + d : constant R := R (Right); + + begin + return (b / d, -a / d); + end "/"; + + function "/" (Left : Imaginary; Right : Complex) return Complex is + b : constant R := R (Left); + c : constant R := Right.Re; + d : constant R := Right.Im; + + begin + return (Re => b * d / (c ** 2 + d ** 2), + Im => b * c / (c ** 2 + d ** 2)); + end "/"; + + function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is + begin + return Imaginary (R (Left) / Right); + end "/"; + + function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is + begin + return Imaginary (-Left / R (Right)); + end "/"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) < R (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) <= R (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) > R (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) >= R (Right); + end ">="; + + ----------- + -- "abs" -- + ----------- + + function "abs" (Right : Imaginary) return Real'Base is + begin + return abs R (Right); + end "abs"; + + -------------- + -- Argument -- + -------------- + + function Argument (X : Complex) return Real'Base is + a : constant R := X.Re; + b : constant R := X.Im; + arg : R; + + begin + if b = 0.0 then + + if a >= 0.0 then + return 0.0; + else + return R'Copy_Sign (Pi, b); + end if; + + elsif a = 0.0 then + + if b >= 0.0 then + return Half_Pi; + else + return -Half_Pi; + end if; + + else + arg := R (Atan (Double (abs (b / a)))); + + if a > 0.0 then + if b > 0.0 then + return arg; + else -- b < 0.0 + return -arg; + end if; + + else -- a < 0.0 + if b >= 0.0 then + return Pi - arg; + else -- b < 0.0 + return -(Pi - arg); + end if; + end if; + end if; + + exception + when Constraint_Error => + if b > 0.0 then + return Half_Pi; + else + return -Half_Pi; + end if; + end Argument; + + function Argument (X : Complex; Cycle : Real'Base) return Real'Base is + begin + if Cycle > 0.0 then + return Argument (X) * Cycle / Two_Pi; + else + raise Argument_Error; + end if; + end Argument; + + ---------------------------- + -- Compose_From_Cartesian -- + ---------------------------- + + function Compose_From_Cartesian (Re, Im : Real'Base) return Complex is + begin + return (Re, Im); + end Compose_From_Cartesian; + + function Compose_From_Cartesian (Re : Real'Base) return Complex is + begin + return (Re, 0.0); + end Compose_From_Cartesian; + + function Compose_From_Cartesian (Im : Imaginary) return Complex is + begin + return (0.0, R (Im)); + end Compose_From_Cartesian; + + ------------------------ + -- Compose_From_Polar -- + ------------------------ + + function Compose_From_Polar ( + Modulus, Argument : Real'Base) + return Complex + is + begin + if Modulus = 0.0 then + return (0.0, 0.0); + else + return (Modulus * R (Cos (Double (Argument))), + Modulus * R (Sin (Double (Argument)))); + end if; + end Compose_From_Polar; + + function Compose_From_Polar ( + Modulus, Argument, Cycle : Real'Base) + return Complex + is + Arg : Real'Base; + + begin + if Modulus = 0.0 then + return (0.0, 0.0); + + elsif Cycle > 0.0 then + if Argument = 0.0 then + return (Modulus, 0.0); + + elsif Argument = Cycle / 4.0 then + return (0.0, Modulus); + + elsif Argument = Cycle / 2.0 then + return (-Modulus, 0.0); + + elsif Argument = 3.0 * Cycle / R (4.0) then + return (0.0, -Modulus); + else + Arg := Two_Pi * Argument / Cycle; + return (Modulus * R (Cos (Double (Arg))), + Modulus * R (Sin (Double (Arg)))); + end if; + else + raise Argument_Error; + end if; + end Compose_From_Polar; + + --------------- + -- Conjugate -- + --------------- + + function Conjugate (X : Complex) return Complex is + begin + return Complex'(X.Re, -X.Im); + end Conjugate; + + -------- + -- Im -- + -------- + + function Im (X : Complex) return Real'Base is + begin + return X.Im; + end Im; + + function Im (X : Imaginary) return Real'Base is + begin + return R (X); + end Im; + + ------------- + -- Modulus -- + ------------- + + function Modulus (X : Complex) return Real'Base is + Re2, Im2 : R; + + begin + + begin + Re2 := X.Re ** 2; + + -- To compute (a**2 + b**2) ** (0.5) when a**2 may be out of bounds, + -- compute a * (1 + (b/a) **2) ** (0.5). On a machine where the + -- squaring does not raise constraint_error but generates infinity, + -- we can use an explicit comparison to determine whether to use + -- the scaling expression. + + if Re2 > R'Last then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + return abs (X.Re) + * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2))); + end; + + begin + Im2 := X.Im ** 2; + + if Im2 > R'Last then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + return abs (X.Im) + * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2))); + end; + + -- Now deal with cases of underflow. If only one of the squares + -- underflows, return the modulus of the other component. If both + -- squares underflow, use scaling as above. + + if Re2 = 0.0 then + + if X.Re = 0.0 then + return abs (X.Im); + + elsif Im2 = 0.0 then + + if X.Im = 0.0 then + return abs (X.Re); + + else + if abs (X.Re) > abs (X.Im) then + return + abs (X.Re) + * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2))); + else + return + abs (X.Im) + * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2))); + end if; + end if; + + else + return abs (X.Im); + end if; + + + elsif Im2 = 0.0 then + return abs (X.Re); + + -- in all other cases, the naive computation will do. + + else + return R (Sqrt (Double (Re2 + Im2))); + end if; + end Modulus; + + -------- + -- Re -- + -------- + + function Re (X : Complex) return Real'Base is + begin + return X.Re; + end Re; + + ------------ + -- Set_Im -- + ------------ + + procedure Set_Im (X : in out Complex; Im : in Real'Base) is + begin + X.Im := Im; + end Set_Im; + + procedure Set_Im (X : out Imaginary; Im : in Real'Base) is + begin + X := Imaginary (Im); + end Set_Im; + + ------------ + -- Set_Re -- + ------------ + + procedure Set_Re (X : in out Complex; Re : in Real'Base) is + begin + X.Re := Re; + end Set_Re; + +end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/a-ngcoty.ads b/gcc/ada/a-ngcoty.ads new file mode 100644 index 00000000000..2c39a926571 --- /dev/null +++ b/gcc/ada/a-ngcoty.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +generic + type Real is digits <>; + +package Ada.Numerics.Generic_Complex_Types is + +pragma Pure (Generic_Complex_Types); + + type Complex is record + Re, Im : Real'Base; + end record; + + pragma Complex_Representation (Complex); + + type Imaginary is private; + + i : constant Imaginary; + j : constant Imaginary; + + function Re (X : Complex) return Real'Base; + function Im (X : Complex) return Real'Base; + function Im (X : Imaginary) return Real'Base; + + procedure Set_Re (X : in out Complex; Re : in Real'Base); + procedure Set_Im (X : in out Complex; Im : in Real'Base); + procedure Set_Im (X : out Imaginary; Im : in Real'Base); + + function Compose_From_Cartesian (Re, Im : Real'Base) return Complex; + function Compose_From_Cartesian (Re : Real'Base) return Complex; + function Compose_From_Cartesian (Im : Imaginary) return Complex; + + function Modulus (X : Complex) return Real'Base; + function "abs" (Right : Complex) return Real'Base renames Modulus; + + function Argument (X : Complex) return Real'Base; + function Argument (X : Complex; Cycle : Real'Base) return Real'Base; + + function Compose_From_Polar ( + Modulus, Argument : Real'Base) + return Complex; + + function Compose_From_Polar ( + Modulus, Argument, Cycle : Real'Base) + return Complex; + + function "+" (Right : Complex) return Complex; + function "-" (Right : Complex) return Complex; + function Conjugate (X : Complex) return Complex; + + function "+" (Left, Right : Complex) return Complex; + function "-" (Left, Right : Complex) return Complex; + function "*" (Left, Right : Complex) return Complex; + function "/" (Left, Right : Complex) return Complex; + + function "**" (Left : Complex; Right : Integer) return Complex; + + function "+" (Right : Imaginary) return Imaginary; + function "-" (Right : Imaginary) return Imaginary; + function Conjugate (X : Imaginary) return Imaginary renames "-"; + function "abs" (Right : Imaginary) return Real'Base; + + function "+" (Left, Right : Imaginary) return Imaginary; + function "-" (Left, Right : Imaginary) return Imaginary; + function "*" (Left, Right : Imaginary) return Real'Base; + function "/" (Left, Right : Imaginary) return Real'Base; + + function "**" (Left : Imaginary; Right : Integer) return Complex; + + function "<" (Left, Right : Imaginary) return Boolean; + function "<=" (Left, Right : Imaginary) return Boolean; + function ">" (Left, Right : Imaginary) return Boolean; + function ">=" (Left, Right : Imaginary) return Boolean; + + function "+" (Left : Complex; Right : Real'Base) return Complex; + function "+" (Left : Real'Base; Right : Complex) return Complex; + function "-" (Left : Complex; Right : Real'Base) return Complex; + function "-" (Left : Real'Base; Right : Complex) return Complex; + function "*" (Left : Complex; Right : Real'Base) return Complex; + function "*" (Left : Real'Base; Right : Complex) return Complex; + function "/" (Left : Complex; Right : Real'Base) return Complex; + function "/" (Left : Real'Base; Right : Complex) return Complex; + + function "+" (Left : Complex; Right : Imaginary) return Complex; + function "+" (Left : Imaginary; Right : Complex) return Complex; + function "-" (Left : Complex; Right : Imaginary) return Complex; + function "-" (Left : Imaginary; Right : Complex) return Complex; + function "*" (Left : Complex; Right : Imaginary) return Complex; + function "*" (Left : Imaginary; Right : Complex) return Complex; + function "/" (Left : Complex; Right : Imaginary) return Complex; + function "/" (Left : Imaginary; Right : Complex) return Complex; + + function "+" (Left : Imaginary; Right : Real'Base) return Complex; + function "+" (Left : Real'Base; Right : Imaginary) return Complex; + function "-" (Left : Imaginary; Right : Real'Base) return Complex; + function "-" (Left : Real'Base; Right : Imaginary) return Complex; + + function "*" (Left : Imaginary; Right : Real'Base) return Imaginary; + function "*" (Left : Real'Base; Right : Imaginary) return Imaginary; + function "/" (Left : Imaginary; Right : Real'Base) return Imaginary; + function "/" (Left : Real'Base; Right : Imaginary) return Imaginary; + +private + type Imaginary is new Real'Base; + + i : constant Imaginary := 1.0; + j : constant Imaginary := 1.0; + + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("*"); + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + pragma Inline ("abs"); + pragma Inline (Compose_From_Cartesian); + pragma Inline (Conjugate); + pragma Inline (Im); + pragma Inline (Re); + pragma Inline (Set_Im); + pragma Inline (Set_Re); + +end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb new file mode 100644 index 00000000000..2a7201e874f --- /dev/null +++ b/gcc/ada/a-ngelfu.adb @@ -0,0 +1,1051 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads new file mode 100644 index 00000000000..7149abecbc4 --- /dev/null +++ b/gcc/ada/a-ngelfu.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Float_Type is digits <>; + +package Ada.Numerics.Generic_Elementary_Functions is +pragma Pure (Generic_Elementary_Functions); + + function Sqrt (X : Float_Type'Base) return Float_Type'Base; + function Log (X : Float_Type'Base) return Float_Type'Base; + function Log (X, Base : Float_Type'Base) return Float_Type'Base; + function Exp (X : Float_Type'Base) return Float_Type'Base; + function "**" (Left, Right : Float_Type'Base) return Float_Type'Base; + + function Sin (X : Float_Type'Base) return Float_Type'Base; + function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Cos (X : Float_Type'Base) return Float_Type'Base; + function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Tan (X : Float_Type'Base) return Float_Type'Base; + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Cot (X : Float_Type'Base) return Float_Type'Base; + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base; + + function Arcsin (X : Float_Type'Base) return Float_Type'Base; + function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Arccos (X : Float_Type'Base) return Float_Type'Base; + function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base; + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) + return Float_Type'Base; + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base; + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0) + return Float_Type'Base; + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base; + + function Sinh (X : Float_Type'Base) return Float_Type'Base; + function Cosh (X : Float_Type'Base) return Float_Type'Base; + function Tanh (X : Float_Type'Base) return Float_Type'Base; + function Coth (X : Float_Type'Base) return Float_Type'Base; + function Arcsinh (X : Float_Type'Base) return Float_Type'Base; + function Arccosh (X : Float_Type'Base) return Float_Type'Base; + function Arctanh (X : Float_Type'Base) return Float_Type'Base; + function Arccoth (X : Float_Type'Base) return Float_Type'Base; + +end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-nlcefu.ads b/gcc/ada/a-nlcefu.ads new file mode 100644 index 00000000000..5ad9a0047cd --- /dev/null +++ b/gcc/ada/a-nlcefu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Complex_Types); diff --git a/gcc/ada/a-nlcoty.ads b/gcc/ada/a-nlcoty.ads new file mode 100644 index 00000000000..cf0476f6c1a --- /dev/null +++ b/gcc/ada/a-nlcoty.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Float); + +pragma Pure (Long_Complex_Types); diff --git a/gcc/ada/a-nlelfu.ads b/gcc/ada/a-nlelfu.ads new file mode 100644 index 00000000000..fe1299809b0 --- /dev/null +++ b/gcc/ada/a-nlelfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Float); + +pragma Pure (Long_Elementary_Functions); diff --git a/gcc/ada/a-nllcef.ads b/gcc/ada/a-nllcef.ads new file mode 100644 index 00000000000..b38e71c548d --- /dev/null +++ b/gcc/ada/a-nllcef.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Long_Complex_Types); diff --git a/gcc/ada/a-nllcty.ads b/gcc/ada/a-nllcty.ads new file mode 100644 index 00000000000..eba55b15004 --- /dev/null +++ b/gcc/ada/a-nllcty.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Long_Float); + +pragma Pure (Long_Long_Complex_Types); diff --git a/gcc/ada/a-nllefu.ads b/gcc/ada/a-nllefu.ads new file mode 100644 index 00000000000..9c9c5c18695 --- /dev/null +++ b/gcc/ada/a-nllefu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); + +pragma Pure (Long_Long_Elementary_Functions); diff --git a/gcc/ada/a-nscefu.ads b/gcc/ada/a-nscefu.ads new file mode 100644 index 00000000000..3d1e76c654a --- /dev/null +++ b/gcc/ada/a-nscefu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT.COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Short_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Short_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Short_Complex_Types); diff --git a/gcc/ada/a-nscoty.ads b/gcc/ada/a-nscoty.ads new file mode 100644 index 00000000000..af1c22e1f92 --- /dev/null +++ b/gcc/ada/a-nscoty.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . S H O R T _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Short_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Short_Float); + +pragma Pure (Short_Complex_Types); diff --git a/gcc/ada/a-nselfu.ads b/gcc/ada/a-nselfu.ads new file mode 100644 index 00000000000..7d7bd774a9e --- /dev/null +++ b/gcc/ada/a-nselfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Short_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Short_Float); + +pragma Pure (Short_Elementary_Functions); diff --git a/gcc/ada/a-nucoty.ads b/gcc/ada/a-nucoty.ads new file mode 100644 index 00000000000..0f1092b1b7a --- /dev/null +++ b/gcc/ada/a-nucoty.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Float); + +pragma Pure (Complex_Types); diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb new file mode 100644 index 00000000000..b029a981ca4 --- /dev/null +++ b/gcc/ada/a-nudira.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; +with Interfaces; use Interfaces; + +package body Ada.Numerics.Discrete_Random is + + ------------------------- + -- Implementation Note -- + ------------------------- + + -- The design of this spec is very awkward, as a result of Ada 95 not + -- permitting in-out parameters for function formals (most naturally + -- Generator values would be passed this way). In pure Ada 95, the only + -- solution is to use the heap and pointers, and, to avoid memory leaks, + -- controlled types. + + -- This is awfully heavy, so what we do is to use Unrestricted_Access to + -- get a pointer to the state in the passed Generator. This works because + -- Generator is a limited type and will thus always be passed by reference. + + type Pointer is access all State; + + Need_64 : constant Boolean := Rst'Pos (Rst'Last) > Int'Last; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Square_Mod_N (X, N : Int) return Int; + pragma Inline (Square_Mod_N); + -- Computes X**2 mod N avoiding intermediate overflow + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & + ',' & + Int'Image (Of_State.X2) & + ',' & + Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Rst is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Temp : Int; + TF : Flt; + + begin + -- Check for flat range here, since we are typically run with checks + -- off, note that in practice, this condition will usually be static + -- so we will not actually generate any code for the normal case. + + if Rst'Last < Rst'First then + raise Constraint_Error; + end if; + + -- Continue with computation if non-flat range + + Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); + Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); + Temp := Genp.X2 - Genp.X1; + + -- Following duplication is not an error, it is a loop unwinding! + + if Temp < 0 then + Temp := Temp + Genp.Q; + end if; + + if Temp < 0 then + Temp := Temp + Genp.Q; + end if; + + TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; + + -- Pathological, but there do exist cases where the rounding implicit + -- in calculating the scale factor will cause rounding to 'Last + 1. + -- In those cases, returning 'First results in the least bias. + + if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then + return Rst'First; + + elsif Need_64 then + return Rst'Val (Interfaces.Integer_64 (TF)); + + else + return Rst'Val (Int (TF)); + end if; + + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; Initiator : Integer) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + -- eliminate effects of small Initiators. + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Now : constant Calendar.Time := Calendar.Clock; + X1 : Int; + X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now) * 31) + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; From_State : State) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.all := From_State; + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + begin + return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Coded_State (Stop) = ','; + end loop; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Coded_State'Last)); + Outs.P := Outs.Q * 2 + 1; + Outs.FP := Flt (Outs.P); + Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks. + + if Outs.Q < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; + +end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads new file mode 100644 index 00000000000..4de490c2494 --- /dev/null +++ b/gcc/ada/a-nudira.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the implementation used in this package was contributed by +-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and +-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The +-- particular choices for P and Q chosen here guarantee a period of +-- 562,085,314,430,582 (about 2**49), and the generated sequence has +-- excellent randomness properties. For further details, see the +-- paper "Fast Generation of Trustworthy Random Numbers", by Robert +-- Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +with Interfaces; + +generic + type Result_Subtype is (<>); + +package Ada.Numerics.Discrete_Random is + + -- Basic facilities. + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities. + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + subtype Int is Interfaces.Integer_32; + subtype Rst is Result_Subtype; + + type Flt is digits 14; + + RstF : constant Flt := Flt (Rst'Pos (Rst'First)); + RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); + + Offs : constant Flt := RstF - 0.5; + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); + + type State is record + X1 : Int := Int (2999 ** 2); + X2 : Int := Int (1439 ** 2); + P : Int := K1; + Q : Int := K2; + FP : Flt := K1F; + Scl : Flt := Scal; + end record; + + type Generator is limited record + Gen_State : State; + end record; + +end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nuelfu.ads b/gcc/ada/a-nuelfu.ads new file mode 100644 index 00000000000..2e6f3b1b98f --- /dev/null +++ b/gcc/ada/a-nuelfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . E L E M E N T A R Y _ F U N C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Float); + +pragma Pure (Elementary_Functions); diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb new file mode 100644 index 00000000000..6c5fe009c97 --- /dev/null +++ b/gcc/ada/a-nuflra.adb @@ -0,0 +1,302 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . F L O A T _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.17 $ -- +-- -- +-- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package body Ada.Numerics.Float_Random is + + ------------------------- + -- Implementation Note -- + ------------------------- + + -- The design of this spec is very awkward, as a result of Ada 95 not + -- permitting in-out parameters for function formals (most naturally + -- Generator values would be passed this way). In pure Ada 95, the only + -- solution is to use the heap and pointers, and, to avoid memory leaks, + -- controlled types. + + -- This is awfully heavy, so what we do is to use Unrestricted_Access to + -- get a pointer to the state in the passed Generator. This works because + -- Generator is a limited type and will thus always be passed by reference. + + type Pointer is access all State; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Euclid (P, Q : in Int; X, Y : out Int; GCD : out Int); + + function Euclid (P, Q : Int) return Int; + + function Square_Mod_N (X, N : Int) return Int; + + ------------ + -- Euclid -- + ------------ + + procedure Euclid (P, Q : in Int; X, Y : out Int; GCD : out Int) is + + XT : Int := 1; + YT : Int := 0; + + procedure Recur + (P, Q : in Int; -- a (i-1), a (i) + X, Y : in Int; -- x (i), y (i) + XP, YP : in out Int; -- x (i-1), y (i-1) + GCD : out Int); + + procedure Recur + (P, Q : in Int; + X, Y : in Int; + XP, YP : in out Int; + GCD : out Int) + is + Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| + XT : Int := X; -- x (i) + YT : Int := Y; -- y (i) + + begin + if P rem Q = 0 then -- while does not divide + GCD := Q; + XP := X; + YP := Y; + else + Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); + + -- a (i) <== a (i) + -- a (i+1) <-- a (i-1) - q*a (i) + -- x (i+1) <-- x (i-1) - q*x (i) + -- y (i+1) <-- y (i-1) - q*y (i) + -- x (i) <== x (i) + -- y (i) <== y (i) + + XP := XT; + YP := YT; + GCD := Quo; + end if; + end Recur; + + -- Start of processing for Euclid + + begin + Recur (P, Q, 0, 1, XT, YT, GCD); + X := XT; + Y := YT; + end Euclid; + + function Euclid (P, Q : Int) return Int is + X, Y, GCD : Int; + + begin + Euclid (P, Q, X, Y, GCD); + return X; + end Euclid; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) + & ',' & + Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Uniformly_Distributed is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); + Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); + return + Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) + mod Genp.Q) * Flt (Genp.P) + + Flt (Genp.X1)) * Genp.Scl); + end Random; + + ----------- + -- Reset -- + ----------- + + -- Version that works from given initiator value + + procedure Reset (Gen : in Generator; Initiator : in Integer) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + -- Eliminate effects of small Initiators. + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + end Reset; + + -- Version that works from specific saved state + + procedure Reset (Gen : Generator; From_State : State) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.all := From_State; + end Reset; + + -- Version that works from calendar + + procedure Reset (Gen : Generator) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Now : constant Calendar.Time := Calendar.Clock; + X1, X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now)) * 31 + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : in Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + Temp : Flt := Flt (X) * Flt (X); + Div : Int := Int (Temp / Flt (N)); + + begin + Div := Int (Temp - Flt (Div) * Flt (N)); + + if Div < 0 then + return Div + N; + else + return Div; + end if; + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Coded_State (Stop) = ','; + end loop; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Coded_State (Stop) = ','; + end loop; + + Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Coded_State'Last)); + Outs.X := Euclid (Outs.P, Outs.Q); + Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks. + + if Outs.Q < 31 or else Outs.P < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; +end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads new file mode 100644 index 00000000000..79f9da5f640 --- /dev/null +++ b/gcc/ada/a-nuflra.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . F L O A T _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the implementation used in this package was contributed by +-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and +-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The +-- particular choices for P and Q chosen here guarantee a period of +-- 562,085,314,430,582 (about 2**49), and the generated sequence has +-- excellent randomness properties. For further details, see the +-- paper "Fast Generation of Trustworthy Random Numbers", by Robert +-- Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. This paper is available at +-- the Ada Core Technologies web site (http://www.gnat.com). + +with Interfaces; + +package Ada.Numerics.Float_Random is + + -- Basic facilities + + type Generator is limited private; + + subtype Uniformly_Distributed is Float range 0.0 .. 1.0; + + function Random (Gen : Generator) return Uniformly_Distributed; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + type Int is new Interfaces.Integer_32; + type Flt is digits 14; + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant := 1.0 / (K1F * K2F); + + type State is record + X1 : Int := 2999 ** 2; -- Square mod p + X2 : Int := 1439 ** 2; -- Square mod q + P : Int := K1; + Q : Int := K2; + X : Int := 1; + Scl : Flt := Scal; + end record; + + type Generator is limited record + Gen_State : State; + end record; + +end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-numaux.ads b/gcc/ada/a-numaux.ads new file mode 100644 index 00000000000..33cc0f493d0 --- /dev/null +++ b/gcc/ada/a-numaux.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version, non-x86) -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable, although it may +-- not necessarily meet the requirements for accuracy in the numerics annex. +-- One advantage of using this package is that it will interface directly to +-- hardware instructions, such as the those provided on the Intel x86. + +-- Note: there are two versions of this package. One using the normal IEEE +-- 64-bit double format (which is this version), and one using 80-bit x86 +-- long double (see file 4onumaux.ads). + +package Ada.Numerics.Aux is +pragma Pure (Aux); + + pragma Linker_Options ("-lm"); + + type Double is digits 15; + pragma Float_Representation (IEEE_Float, Double); + -- Type Double is the type used to call the C routines. Note that this + -- is IEEE format even when running on VMS with Vax_Float representation + -- since we use the IEEE version of the C library with VMS. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numeri.ads b/gcc/ada/a-numeri.ads new file mode 100644 index 00000000000..5b0f6e0077f --- /dev/null +++ b/gcc/ada/a-numeri.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + + +package Ada.Numerics is +pragma Pure (Numerics); + + Argument_Error : exception; + + Pi : constant := + 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; + + e : constant := + 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; + +end Ada.Numerics; diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb new file mode 100644 index 00000000000..8854922d200 --- /dev/null +++ b/gcc/ada/a-reatim.adb @@ -0,0 +1,208 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.34 $ +-- -- +-- Copyright (C) 1991-2001, Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +-- used for Monotonic_Clock + +package body Ada.Real_Time is + + --------- + -- "*" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "*" (Left : Time_Span; Right : Integer) return Time_Span is + begin + return Time_Span (Duration (Left) * Right); + end "*"; + + function "*" (Left : Integer; Right : Time_Span) return Time_Span is + begin + return Time_Span (Left * Duration (Right)); + end "*"; + + --------- + -- "+" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "+" (Left : Time; Right : Time_Span) return Time is + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left : Time_Span; Right : Time) return Time is + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left, Right : Time_Span) return Time_Span is + begin + return Time_Span (Duration (Left) + Duration (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "-" (Left : Time; Right : Time_Span) return Time is + begin + return Time (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time) return Time_Span is + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time_Span) return Time_Span is + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Right : Time_Span) return Time_Span is + begin + return Time_Span_Zero - Right; + end "-"; + + --------- + -- "/" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "/" (Left, Right : Time_Span) return Integer is + begin + return Integer (Duration (Left) / Duration (Right)); + end "/"; + + function "/" (Left : Time_Span; Right : Integer) return Time_Span is + begin + return Time_Span (Duration (Left) / Right); + end "/"; + + ----------- + -- Clock -- + ----------- + + function Clock return Time is + begin + return Time (System.Task_Primitives.Operations.Monotonic_Clock); + end Clock; + + ------------------ + -- Microseconds -- + ------------------ + + function Microseconds (US : Integer) return Time_Span is + begin + return Time_Span_Unit * US * 1_000; + end Microseconds; + + ------------------ + -- Milliseconds -- + ------------------ + + function Milliseconds (MS : Integer) return Time_Span is + begin + return Time_Span_Unit * MS * 1_000_000; + end Milliseconds; + + ----------------- + -- Nanoseconds -- + ----------------- + + function Nanoseconds (NS : Integer) return Time_Span is + begin + return Time_Span_Unit * NS; + end Nanoseconds; + + ----------- + -- Split -- + ----------- + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is + begin + -- Extract the integer part of T + + if T = 0.0 then + SC := 0; + else + SC := Seconds_Count (Time_Span'(T - 0.5)); + end if; + + -- Since we loose precision when converting a time value to float, + -- we need to add this check + + if Time (SC) > T then + SC := SC - 1; + end if; + + TS := T - Time (SC); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is + begin + return Time (SC) + TS; + end Time_Of; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : Time_Span) return Duration is + begin + return Duration (TS); + end To_Duration; + + ------------------ + -- To_Time_Span -- + ------------------ + + function To_Time_Span (D : Duration) return Time_Span is + begin + return Time_Span (D); + end To_Time_Span; + +end Ada.Real_Time; diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads new file mode 100644 index 00000000000..9fe47621998 --- /dev/null +++ b/gcc/ada/a-reatim.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.24 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +pragma Elaborate_All (System.Task_Primitives.Operations); + +package Ada.Real_Time is + + type Time is private; + Time_First : constant Time; + Time_Last : constant Time; + Time_Unit : constant := 10#1.0#E-9; + + type Time_Span is private; + Time_Span_First : constant Time_Span; + Time_Span_Last : constant Time_Span; + Time_Span_Zero : constant Time_Span; + Time_Span_Unit : constant Time_Span; + + Tick : constant Time_Span; + function Clock return Time; + + function "+" (Left : Time; Right : Time_Span) return Time; + function "+" (Left : Time_Span; Right : Time) return Time; + function "-" (Left : Time; Right : Time_Span) return Time; + function "-" (Left : Time; Right : Time) return Time_Span; + + function "<" (Left, Right : Time) return Boolean; + function "<=" (Left, Right : Time) return Boolean; + function ">" (Left, Right : Time) return Boolean; + function ">=" (Left, Right : Time) return Boolean; + + function "+" (Left, Right : Time_Span) return Time_Span; + function "-" (Left, Right : Time_Span) return Time_Span; + function "-" (Right : Time_Span) return Time_Span; + function "*" (Left : Time_Span; Right : Integer) return Time_Span; + function "*" (Left : Integer; Right : Time_Span) return Time_Span; + function "/" (Left, Right : Time_Span) return Integer; + function "/" (Left : Time_Span; Right : Integer) return Time_Span; + + function "abs" (Right : Time_Span) return Time_Span; + + function "<" (Left, Right : Time_Span) return Boolean; + function "<=" (Left, Right : Time_Span) return Boolean; + function ">" (Left, Right : Time_Span) return Boolean; + function ">=" (Left, Right : Time_Span) return Boolean; + + function To_Duration (TS : Time_Span) return Duration; + function To_Time_Span (D : Duration) return Time_Span; + + function Nanoseconds (NS : Integer) return Time_Span; + function Microseconds (US : Integer) return Time_Span; + function Milliseconds (MS : Integer) return Time_Span; + + type Seconds_Count is new Integer range -Integer'Last .. Integer'Last; + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span); + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time; + +private + type Time is new Duration; + + Time_First : constant Time := Time'First; + + Time_Last : constant Time := Time'Last; + + type Time_Span is new Duration; + + Time_Span_First : constant Time_Span := Time_Span'First; + + Time_Span_Last : constant Time_Span := Time_Span'Last; + + Time_Span_Zero : constant Time_Span := 0.0; + + Time_Span_Unit : constant Time_Span := 10#1.0#E-9; + + Tick : constant Time_Span := + Time_Span (System.Task_Primitives.Operations.RT_Resolution); + + -- Time and Time_Span are represented in 64-bit Duration value in + -- in nanoseconds. For example, 1 second and 1 nanosecond is + -- represented as the stored integer 1_000_000_001. + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "abs"); + +end Ada.Real_Time; diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb new file mode 100644 index 00000000000..4f33a429f9d --- /dev/null +++ b/gcc/ada/a-retide.adb @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.28 $ +-- -- +-- Copyright (C) 1991-1999 Florida State University -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +-- Used for Timed_Delay + +with System.OS_Primitives; +-- Used for Delay_Modes + +package body Ada.Real_Time.Delays is + + package STPO renames System.Task_Primitives.Operations; + package OSP renames System.OS_Primitives; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + begin + STPO.Timed_Delay (STPO.Self, To_Duration (T), OSP.Absolute_RT); + end Delay_Until; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + begin + return To_Duration (Time_Span (T)); + end To_Duration; + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-retide.ads b/gcc/ada/a-retide.ads new file mode 100644 index 00000000000..f752e7afdb1 --- /dev/null +++ b/gcc/ada/a-retide.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------- +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Implements Real_Time.Time absolute delays + +-- Note: the compiler generates direct calls to this interface, in the +-- processing of time types. + +package Ada.Real_Time.Delays is + + function To_Duration (T : Real_Time.Time) return Duration; + + procedure Delay_Until (T : Time); + -- Delay until Clock has reached (at least) time T, + -- or the task is aborted to at least the current ATC nesting level. + -- The body of this procedure must perform all the processing + -- required for an abortion point. + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb new file mode 100644 index 00000000000..e7a25efc3ac --- /dev/null +++ b/gcc/ada/a-sequio.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Sequential_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Sequential_IO +-- (for specialized Sequential_IO functions) + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; +with System.File_Control_Block; +with System.File_IO; +with System.Storage_Elements; +with Unchecked_Conversion; + +package body Ada.Sequential_IO is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package SIO renames System.Sequential_IO; + package SSE renames System.Storage_Elements; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is SIO.File_Type; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : in File_Mode := Out_File; + Name : in String := ""; + Form : in String := "") + is + begin + SIO.Create (FP (File), To_FCB (Mode), Name, Form); + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : in File_Type) return Boolean is + begin + return FIO.End_Of_File (AP (File)); + end End_Of_File; + + ---------- + -- Form -- + ---------- + + function Form (File : in File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : in File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : in File_Type) return File_Mode is + begin + return To_SIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : in File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + Name : in String; + Form : in String := "") + is + begin + SIO.Open (FP (File), To_FCB (Mode), Name, Form); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read (File : in File_Type; Item : out Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + Rsiz : size_t; + + begin + FIO.Check_Read_Status (AP (File)); + + -- For non-definite type or type with discriminants, read size and + -- raise Program_Error if it is larger than the size of the item. + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + FIO.Read_Buf + (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); + + -- For a type with discriminants, we have to read into a temporary + -- buffer if Item is constrained, to check that the discriminants + -- are correct. + + pragma Extensions_Allowed (On); + -- Needed to allow Constrained reference here + + if Element_Type'Has_Discriminants + and then Item'Constrained + then + declare + RsizS : constant SSE.Storage_Offset := + SSE.Storage_Offset (Rsiz - 1); + + subtype SA is SSE.Storage_Array (0 .. RsizS); + type SAP is access all SA; + type ItemP is access all Element_Type; + + pragma Warnings (Off); + -- We have to turn warnings off for this function, because + -- it gets analyzed for all types, including ones which + -- can't possibly come this way, and for which the size + -- of the access types differs. + + function To_ItemP is new Unchecked_Conversion (SAP, ItemP); + + pragma Warnings (On); + + Buffer : aliased SA; + + pragma Unsuppress (Discriminant_Check); + + begin + FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); + Item := To_ItemP (Buffer'Access).all; + return; + end; + end if; + + -- In the case of a non-definite type, make sure the length is OK. + -- We can't do this in the variant record case, because the size is + -- based on the current discriminant, so may be apparently wrong. + + if not Element_Type'Has_Discriminants and then Rsiz > Siz then + raise Program_Error; + end if; + + FIO.Read_Buf (AP (File), Item'Address, Rsiz); + + -- For definite type without discriminants, use actual size of item + + else + FIO.Read_Buf (AP (File), Item'Address, Siz); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : in File_Mode) is + begin + FIO.Reset (AP (File), To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + FIO.Reset (AP (File)); + end Reset; + + ----------- + -- Write -- + ----------- + + procedure Write (File : in File_Type; Item : in Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + + begin + FIO.Check_Write_Status (AP (File)); + + -- For non-definite types or types with discriminants, write the size + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + FIO.Write_Buf + (AP (File), Siz'Address, size_t'Size / System.Storage_Unit); + end if; + + FIO.Write_Buf (AP (File), Item'Address, Siz); + end Write; + +end Ada.Sequential_IO; diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads new file mode 100644 index 00000000000..b2093c0c189 --- /dev/null +++ b/gcc/ada/a-sequio.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + +with Ada.IO_Exceptions; +with System.Sequential_IO; + +generic + type Element_Type (<>) is private; + +package Ada.Sequential_IO is + + type File_Type is limited private; + + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + --------------------- + -- File management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : in File_Mode := Out_File; + Name : in String := ""; + Form : in String := ""); + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + Name : in String; + Form : in String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : in File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : in File_Type) return File_Mode; + function Name (File : in File_Type) return String; + function Form (File : in File_Type) return String; + + function Is_Open (File : in File_Type) return Boolean; + + --------------------------------- + -- Input and output operations -- + --------------------------------- + + procedure Read (File : in File_Type; Item : out Element_Type); + procedure Write (File : in File_Type; Item : in Element_Type); + + function End_Of_File (File : in File_Type) return Boolean; + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + +private + type File_Type is new System.Sequential_IO.File_Type; + + -- All subprograms are inlined + + pragma Inline (Close); + pragma Inline (Create); + pragma Inline (Delete); + pragma Inline (End_Of_File); + pragma Inline (Form); + pragma Inline (Is_Open); + pragma Inline (Mode); + pragma Inline (Name); + pragma Inline (Open); + pragma Inline (Read); + pragma Inline (Reset); + pragma Inline (Write); + +end Ada.Sequential_IO; diff --git a/gcc/ada/a-sfteio.ads b/gcc/ada/a-sfteio.ads new file mode 100644 index 00000000000..dd16f1f35b2 --- /dev/null +++ b/gcc/ada/a-sfteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Float_Text_IO is + new Ada.Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-sfwtio.ads b/gcc/ada/a-sfwtio.ads new file mode 100644 index 00000000000..5fa8cc53309 --- /dev/null +++ b/gcc/ada/a-sfwtio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-siocst.adb b/gcc/ada/a-siocst.adb new file mode 100644 index 00000000000..cd48603f3bb --- /dev/null +++ b/gcc/ada/a-siocst.adb @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with System.Sequential_IO; +with Unchecked_Conversion; + +package body Ada.Sequential_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package SIO renames System.Sequential_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in FILEs; + Form : in String := "") + is + File_Control_Block : SIO.Sequential_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => To_FCB (Mode), + Name => "", + Form => Form, + Amethod => 'Q', + Creat => False, + Text => False, + C_Stream => C_Stream); + end Open; + +end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/a-siocst.ads b/gcc/ada/a-siocst.ads new file mode 100644 index 00000000000..b057f40daed --- /dev/null +++ b/gcc/ada/a-siocst.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Sequential_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Sequential_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in ICS.FILEs; + Form : in String := ""); + -- Create new file from existing stream + +end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/a-siteio.ads b/gcc/ada/a-siteio.ads new file mode 100644 index 00000000000..8803a6ae2f3 --- /dev/null +++ b/gcc/ada/a-siteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-siwtio.ads b/gcc/ada/a-siwtio.ads new file mode 100644 index 00000000000..dc10fa3d15b --- /dev/null +++ b/gcc/ada/a-siwtio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-ssicst.adb b/gcc/ada/a-ssicst.adb new file mode 100644 index 00000000000..88256205b2b --- /dev/null +++ b/gcc/ada/a-ssicst.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Unchecked_Conversion; + +package body Ada.Streams.Stream_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in FILEs; + Form : in String := "") + is + File_Control_Block : Stream_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => To_FCB (Mode), + Name => "", + Form => Form, + Amethod => 'S', + Creat => False, + Text => False, + C_Stream => C_Stream); + end Open; + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssicst.ads b/gcc/ada/a-ssicst.ads new file mode 100644 index 00000000000..a0c930e8068 --- /dev/null +++ b/gcc/ada/a-ssicst.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Stream_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Streams.Stream_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : in File_Mode; + C_Stream : in ICS.FILEs; + Form : in String := ""); + -- Create new file from existing stream + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssitio.ads b/gcc/ada/a-ssitio.ads new file mode 100644 index 00000000000..0a307257e41 --- /dev/null +++ b/gcc/ada/a-ssitio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-ssiwti.ads b/gcc/ada/a-ssiwti.ads new file mode 100644 index 00000000000..0ab8d3f9475 --- /dev/null +++ b/gcc/ada/a-ssiwti.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-stmaco.ads b/gcc/ada/a-stmaco.ads new file mode 100644 index 00000000000..9519c5b3f19 --- /dev/null +++ b/gcc/ada/a-stmaco.ads @@ -0,0 +1,918 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . M A P S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; + +package Ada.Strings.Maps.Constants is +pragma Preelaborate (Constants); + + Control_Set : constant Character_Set; + Graphic_Set : constant Character_Set; + Letter_Set : constant Character_Set; + Lower_Set : constant Character_Set; + Upper_Set : constant Character_Set; + Basic_Set : constant Character_Set; + Decimal_Digit_Set : constant Character_Set; + Hexadecimal_Digit_Set : constant Character_Set; + Alphanumeric_Set : constant Character_Set; + Special_Set : constant Character_Set; + ISO_646_Set : constant Character_Set; + + Lower_Case_Map : constant Character_Mapping; + -- Maps to lower case for letters, else identity + + Upper_Case_Map : constant Character_Mapping; + -- Maps to upper case for letters, else identity + + Basic_Map : constant Character_Mapping; + -- Maps to basic letters for letters, else identity + +private + package L renames Ada.Characters.Latin_1; + + Control_Set : constant Character_Set := + (L.NUL .. L.US => True, + L.DEL .. L.APC => True, + others => False); + + Graphic_Set : constant Character_Set := + (L.Space .. L.Tilde => True, + L.No_Break_Space .. L.LC_Y_Diaeresis => True, + others => False); + + Letter_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Lower_Set : constant Character_Set := + (L.LC_A .. L.LC_Z => True, + L.LC_German_Sharp_S .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Upper_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.UC_Icelandic_Thorn => True, + others => False); + + Basic_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_AE_Diphthong .. L.UC_AE_Diphthong => True, + L.LC_AE_Diphthong .. L.LC_AE_Diphthong => True, + L.LC_German_Sharp_S .. L.LC_German_Sharp_S => True, + L.UC_Icelandic_Thorn .. L.UC_Icelandic_Thorn => True, + L.LC_Icelandic_Thorn .. L.LC_Icelandic_Thorn => True, + L.UC_Icelandic_Eth .. L.UC_Icelandic_Eth => True, + L.LC_Icelandic_Eth .. L.LC_Icelandic_Eth => True, + others => False); + + Decimal_Digit_Set : constant Character_Set := + ('0' .. '9' => True, + others => False); + + Hexadecimal_Digit_Set : constant Character_Set := + ('0' .. '9' => True, + 'A' .. 'F' => True, + L.LC_A .. L.LC_F => True, + others => False); + + Alphanumeric_Set : constant Character_Set := + ('0' .. '9' => True, + 'A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Special_Set : constant Character_Set := + (L.Space .. L.Solidus => True, + L.Colon .. L.Commercial_At => True, + L.Left_Square_Bracket .. L.Grave => True, + L.Left_Curly_Bracket .. L.Tilde => True, + L.No_Break_Space .. L.Inverted_Question => True, + L.Multiplication_Sign .. L.Multiplication_Sign => True, + L.Division_Sign .. L.Division_Sign => True, + others => False); + + ISO_646_Set : constant Character_Set := + (L.NUL .. L.DEL => True, + others => False); + + Lower_Case_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + L.LC_A & -- 'a' 65 + L.LC_B & -- 'b' 66 + L.LC_C & -- 'c' 67 + L.LC_D & -- 'd' 68 + L.LC_E & -- 'e' 69 + L.LC_F & -- 'f' 70 + L.LC_G & -- 'g' 71 + L.LC_H & -- 'h' 72 + L.LC_I & -- 'i' 73 + L.LC_J & -- 'j' 74 + L.LC_K & -- 'k' 75 + L.LC_L & -- 'l' 76 + L.LC_M & -- 'm' 77 + L.LC_N & -- 'n' 78 + L.LC_O & -- 'o' 79 + L.LC_P & -- 'p' 80 + L.LC_Q & -- 'q' 81 + L.LC_R & -- 'r' 82 + L.LC_S & -- 's' 83 + L.LC_T & -- 't' 84 + L.LC_U & -- 'u' 85 + L.LC_V & -- 'v' 86 + L.LC_W & -- 'w' 87 + L.LC_X & -- 'x' 88 + L.LC_Y & -- 'y' 89 + L.LC_Z & -- 'z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + L.LC_A & -- 'a' 97 + L.LC_B & -- 'b' 98 + L.LC_C & -- 'c' 99 + L.LC_D & -- 'd' 100 + L.LC_E & -- 'e' 101 + L.LC_F & -- 'f' 102 + L.LC_G & -- 'g' 103 + L.LC_H & -- 'h' 104 + L.LC_I & -- 'i' 105 + L.LC_J & -- 'j' 106 + L.LC_K & -- 'k' 107 + L.LC_L & -- 'l' 108 + L.LC_M & -- 'm' 109 + L.LC_N & -- 'n' 110 + L.LC_O & -- 'o' 111 + L.LC_P & -- 'p' 112 + L.LC_Q & -- 'q' 113 + L.LC_R & -- 'r' 114 + L.LC_S & -- 's' 115 + L.LC_T & -- 't' 116 + L.LC_U & -- 'u' 117 + L.LC_V & -- 'v' 118 + L.LC_W & -- 'w' 119 + L.LC_X & -- 'x' 120 + L.LC_Y & -- 'y' 121 + L.LC_Z & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + L.LC_A_Grave & -- UC_A_Grave 192 + L.LC_A_Acute & -- UC_A_Acute 193 + L.LC_A_Circumflex & -- UC_A_Circumflex 194 + L.LC_A_Tilde & -- UC_A_Tilde 195 + L.LC_A_Diaeresis & -- UC_A_Diaeresis 196 + L.LC_A_Ring & -- UC_A_Ring 197 + L.LC_AE_Diphthong & -- UC_AE_Diphthong 198 + L.LC_C_Cedilla & -- UC_C_Cedilla 199 + L.LC_E_Grave & -- UC_E_Grave 200 + L.LC_E_Acute & -- UC_E_Acute 201 + L.LC_E_Circumflex & -- UC_E_Circumflex 202 + L.LC_E_Diaeresis & -- UC_E_Diaeresis 203 + L.LC_I_Grave & -- UC_I_Grave 204 + L.LC_I_Acute & -- UC_I_Acute 205 + L.LC_I_Circumflex & -- UC_I_Circumflex 206 + L.LC_I_Diaeresis & -- UC_I_Diaeresis 207 + L.LC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + L.LC_N_Tilde & -- UC_N_Tilde 209 + L.LC_O_Grave & -- UC_O_Grave 210 + L.LC_O_Acute & -- UC_O_Acute 211 + L.LC_O_Circumflex & -- UC_O_Circumflex 212 + L.LC_O_Tilde & -- UC_O_Tilde 213 + L.LC_O_Diaeresis & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + L.LC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 + L.LC_U_Grave & -- UC_U_Grave 217 + L.LC_U_Acute & -- UC_U_Acute 218 + L.LC_U_Circumflex & -- UC_U_Circumflex 219 + L.LC_U_Diaeresis & -- UC_U_Diaeresis 220 + L.LC_Y_Acute & -- UC_Y_Acute 221 + L.LC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.LC_A_Grave & -- LC_A_Grave 224 + L.LC_A_Acute & -- LC_A_Acute 225 + L.LC_A_Circumflex & -- LC_A_Circumflex 226 + L.LC_A_Tilde & -- LC_A_Tilde 227 + L.LC_A_Diaeresis & -- LC_A_Diaeresis 228 + L.LC_A_Ring & -- LC_A_Ring 229 + L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.LC_C_Cedilla & -- LC_C_Cedilla 231 + L.LC_E_Grave & -- LC_E_Grave 232 + L.LC_E_Acute & -- LC_E_Acute 233 + L.LC_E_Circumflex & -- LC_E_Circumflex 234 + L.LC_E_Diaeresis & -- LC_E_Diaeresis 235 + L.LC_I_Grave & -- LC_I_Grave 236 + L.LC_I_Acute & -- LC_I_Acute 237 + L.LC_I_Circumflex & -- LC_I_Circumflex 238 + L.LC_I_Diaeresis & -- LC_I_Diaeresis 239 + L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.LC_N_Tilde & -- LC_N_Tilde 241 + L.LC_O_Grave & -- LC_O_Grave 242 + L.LC_O_Acute & -- LC_O_Acute 243 + L.LC_O_Circumflex & -- LC_O_Circumflex 244 + L.LC_O_Tilde & -- LC_O_Tilde 245 + L.LC_O_Diaeresis & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 + L.LC_U_Grave & -- LC_U_Grave 249 + L.LC_U_Acute & -- LC_U_Acute 250 + L.LC_U_Circumflex & -- LC_U_Circumflex 251 + L.LC_U_Diaeresis & -- LC_U_Diaeresis 252 + L.LC_Y_Acute & -- LC_Y_Acute 253 + L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 + + Upper_Case_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + 'A' & -- 'A' 65 + 'B' & -- 'B' 66 + 'C' & -- 'C' 67 + 'D' & -- 'D' 68 + 'E' & -- 'E' 69 + 'F' & -- 'F' 70 + 'G' & -- 'G' 71 + 'H' & -- 'H' 72 + 'I' & -- 'I' 73 + 'J' & -- 'J' 74 + 'K' & -- 'K' 75 + 'L' & -- 'L' 76 + 'M' & -- 'M' 77 + 'N' & -- 'N' 78 + 'O' & -- 'O' 79 + 'P' & -- 'P' 80 + 'Q' & -- 'Q' 81 + 'R' & -- 'R' 82 + 'S' & -- 'S' 83 + 'T' & -- 'T' 84 + 'U' & -- 'U' 85 + 'V' & -- 'V' 86 + 'W' & -- 'W' 87 + 'X' & -- 'X' 88 + 'Y' & -- 'Y' 89 + 'Z' & -- 'Z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + 'A' & -- 'a' 97 + 'B' & -- 'b' 98 + 'C' & -- 'c' 99 + 'D' & -- 'd' 100 + 'E' & -- 'e' 101 + 'F' & -- 'f' 102 + 'G' & -- 'g' 103 + 'H' & -- 'h' 104 + 'I' & -- 'i' 105 + 'J' & -- 'j' 106 + 'K' & -- 'k' 107 + 'L' & -- 'l' 108 + 'M' & -- 'm' 109 + 'N' & -- 'n' 110 + 'O' & -- 'o' 111 + 'P' & -- 'p' 112 + 'Q' & -- 'q' 113 + 'R' & -- 'r' 114 + 'S' & -- 's' 115 + 'T' & -- 't' 116 + 'U' & -- 'u' 117 + 'V' & -- 'v' 118 + 'W' & -- 'w' 119 + 'X' & -- 'x' 120 + 'Y' & -- 'y' 121 + 'Z' & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + L.UC_A_Grave & -- UC_A_Grave 192 + L.UC_A_Acute & -- UC_A_Acute 193 + L.UC_A_Circumflex & -- UC_A_Circumflex 194 + L.UC_A_Tilde & -- UC_A_Tilde 195 + L.UC_A_Diaeresis & -- UC_A_Diaeresis 196 + L.UC_A_Ring & -- UC_A_Ring 197 + L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 + L.UC_C_Cedilla & -- UC_C_Cedilla 199 + L.UC_E_Grave & -- UC_E_Grave 200 + L.UC_E_Acute & -- UC_E_Acute 201 + L.UC_E_Circumflex & -- UC_E_Circumflex 202 + L.UC_E_Diaeresis & -- UC_E_Diaeresis 203 + L.UC_I_Grave & -- UC_I_Grave 204 + L.UC_I_Acute & -- UC_I_Acute 205 + L.UC_I_Circumflex & -- UC_I_Circumflex 206 + L.UC_I_Diaeresis & -- UC_I_Diaeresis 207 + L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + L.UC_N_Tilde & -- UC_N_Tilde 209 + L.UC_O_Grave & -- UC_O_Grave 210 + L.UC_O_Acute & -- UC_O_Acute 211 + L.UC_O_Circumflex & -- UC_O_Circumflex 212 + L.UC_O_Tilde & -- UC_O_Tilde 213 + L.UC_O_Diaeresis & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 + L.UC_U_Grave & -- UC_U_Grave 217 + L.UC_U_Acute & -- UC_U_Acute 218 + L.UC_U_Circumflex & -- UC_U_Circumflex 219 + L.UC_U_Diaeresis & -- UC_U_Diaeresis 220 + L.UC_Y_Acute & -- UC_Y_Acute 221 + L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.UC_A_Grave & -- LC_A_Grave 224 + L.UC_A_Acute & -- LC_A_Acute 225 + L.UC_A_Circumflex & -- LC_A_Circumflex 226 + L.UC_A_Tilde & -- LC_A_Tilde 227 + L.UC_A_Diaeresis & -- LC_A_Diaeresis 228 + L.UC_A_Ring & -- LC_A_Ring 229 + L.UC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.UC_C_Cedilla & -- LC_C_Cedilla 231 + L.UC_E_Grave & -- LC_E_Grave 232 + L.UC_E_Acute & -- LC_E_Acute 233 + L.UC_E_Circumflex & -- LC_E_Circumflex 234 + L.UC_E_Diaeresis & -- LC_E_Diaeresis 235 + L.UC_I_Grave & -- LC_I_Grave 236 + L.UC_I_Acute & -- LC_I_Acute 237 + L.UC_I_Circumflex & -- LC_I_Circumflex 238 + L.UC_I_Diaeresis & -- LC_I_Diaeresis 239 + L.UC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.UC_N_Tilde & -- LC_N_Tilde 241 + L.UC_O_Grave & -- LC_O_Grave 242 + L.UC_O_Acute & -- LC_O_Acute 243 + L.UC_O_Circumflex & -- LC_O_Circumflex 244 + L.UC_O_Tilde & -- LC_O_Tilde 245 + L.UC_O_Diaeresis & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.UC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 + L.UC_U_Grave & -- LC_U_Grave 249 + L.UC_U_Acute & -- LC_U_Acute 250 + L.UC_U_Circumflex & -- LC_U_Circumflex 251 + L.UC_U_Diaeresis & -- LC_U_Diaeresis 252 + L.UC_Y_Acute & -- LC_Y_Acute 253 + L.UC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 + + Basic_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + 'A' & -- 'A' 65 + 'B' & -- 'B' 66 + 'C' & -- 'C' 67 + 'D' & -- 'D' 68 + 'E' & -- 'E' 69 + 'F' & -- 'F' 70 + 'G' & -- 'G' 71 + 'H' & -- 'H' 72 + 'I' & -- 'I' 73 + 'J' & -- 'J' 74 + 'K' & -- 'K' 75 + 'L' & -- 'L' 76 + 'M' & -- 'M' 77 + 'N' & -- 'N' 78 + 'O' & -- 'O' 79 + 'P' & -- 'P' 80 + 'Q' & -- 'Q' 81 + 'R' & -- 'R' 82 + 'S' & -- 'S' 83 + 'T' & -- 'T' 84 + 'U' & -- 'U' 85 + 'V' & -- 'V' 86 + 'W' & -- 'W' 87 + 'X' & -- 'X' 88 + 'Y' & -- 'Y' 89 + 'Z' & -- 'Z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + L.LC_A & -- 'a' 97 + L.LC_B & -- 'b' 98 + L.LC_C & -- 'c' 99 + L.LC_D & -- 'd' 100 + L.LC_E & -- 'e' 101 + L.LC_F & -- 'f' 102 + L.LC_G & -- 'g' 103 + L.LC_H & -- 'h' 104 + L.LC_I & -- 'i' 105 + L.LC_J & -- 'j' 106 + L.LC_K & -- 'k' 107 + L.LC_L & -- 'l' 108 + L.LC_M & -- 'm' 109 + L.LC_N & -- 'n' 110 + L.LC_O & -- 'o' 111 + L.LC_P & -- 'p' 112 + L.LC_Q & -- 'q' 113 + L.LC_R & -- 'r' 114 + L.LC_S & -- 's' 115 + L.LC_T & -- 't' 116 + L.LC_U & -- 'u' 117 + L.LC_V & -- 'v' 118 + L.LC_W & -- 'w' 119 + L.LC_X & -- 'x' 120 + L.LC_Y & -- 'y' 121 + L.LC_Z & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + 'A' & -- UC_A_Grave 192 + 'A' & -- UC_A_Acute 193 + 'A' & -- UC_A_Circumflex 194 + 'A' & -- UC_A_Tilde 195 + 'A' & -- UC_A_Diaeresis 196 + 'A' & -- UC_A_Ring 197 + L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 + 'C' & -- UC_C_Cedilla 199 + 'E' & -- UC_E_Grave 200 + 'E' & -- UC_E_Acute 201 + 'E' & -- UC_E_Circumflex 202 + 'E' & -- UC_E_Diaeresis 203 + 'I' & -- UC_I_Grave 204 + 'I' & -- UC_I_Acute 205 + 'I' & -- UC_I_Circumflex 206 + 'I' & -- UC_I_Diaeresis 207 + L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + 'N' & -- UC_N_Tilde 209 + 'O' & -- UC_O_Grave 210 + 'O' & -- UC_O_Acute 211 + 'O' & -- UC_O_Circumflex 212 + 'O' & -- UC_O_Tilde 213 + 'O' & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + 'O' & -- UC_O_Oblique_Stroke 216 + 'U' & -- UC_U_Grave 217 + 'U' & -- UC_U_Acute 218 + 'U' & -- UC_U_Circumflex 219 + 'U' & -- UC_U_Diaeresis 220 + 'Y' & -- UC_Y_Acute 221 + L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.LC_A & -- LC_A_Grave 224 + L.LC_A & -- LC_A_Acute 225 + L.LC_A & -- LC_A_Circumflex 226 + L.LC_A & -- LC_A_Tilde 227 + L.LC_A & -- LC_A_Diaeresis 228 + L.LC_A & -- LC_A_Ring 229 + L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.LC_C & -- LC_C_Cedilla 231 + L.LC_E & -- LC_E_Grave 232 + L.LC_E & -- LC_E_Acute 233 + L.LC_E & -- LC_E_Circumflex 234 + L.LC_E & -- LC_E_Diaeresis 235 + L.LC_I & -- LC_I_Grave 236 + L.LC_I & -- LC_I_Acute 237 + L.LC_I & -- LC_I_Circumflex 238 + L.LC_I & -- LC_I_Diaeresis 239 + L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.LC_N & -- LC_N_Tilde 241 + L.LC_O & -- LC_O_Grave 242 + L.LC_O & -- LC_O_Acute 243 + L.LC_O & -- LC_O_Circumflex 244 + L.LC_O & -- LC_O_Tilde 245 + L.LC_O & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.LC_O & -- LC_O_Oblique_Stroke 248 + L.LC_U & -- LC_U_Grave 249 + L.LC_U & -- LC_U_Acute 250 + L.LC_U & -- LC_U_Circumflex 251 + L.LC_U & -- LC_U_Diaeresis 252 + L.LC_Y & -- LC_Y_Acute 253 + L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y); -- LC_Y_Diaeresis 255 + +end Ada.Strings.Maps.Constants; diff --git a/gcc/ada/a-storio.adb b/gcc/ada/a-storio.adb new file mode 100644 index 00000000000..5e4fdf252c4 --- /dev/null +++ b/gcc/ada/a-storio.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T O R A G E _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_To_Access_Conversions; + +package body Ada.Storage_IO is + + package Element_Ops is new + System.Address_To_Access_Conversions (Element_Type); + + ---------- + -- Read -- + ---------- + + procedure Read (Buffer : in Buffer_Type; Item : out Element_Type) is + begin + Element_Ops.To_Pointer (Item'Address).all := + Element_Ops.To_Pointer (Buffer'Address).all; + end Read; + + + ----------- + -- Write -- + ----------- + + procedure Write (Buffer : out Buffer_Type; Item : in Element_Type) is + begin + Element_Ops.To_Pointer (Buffer'Address).all := + Element_Ops.To_Pointer (Item'Address).all; + end Write; + +end Ada.Storage_IO; diff --git a/gcc/ada/a-storio.ads b/gcc/ada/a-storio.ads new file mode 100644 index 00000000000..2c53e7e91f0 --- /dev/null +++ b/gcc/ada/a-storio.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T O R A G E _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Storage_Elements; + +generic + type Element_Type is private; + +package Ada.Storage_IO is +pragma Preelaborate (Storage_IO); + + Buffer_Size : constant System.Storage_Elements.Storage_Count := + System.Storage_Elements.Storage_Count + ((Element_Type'Size + System.Storage_Unit - 1) / + System.Storage_Unit); + + subtype Buffer_Type is + System.Storage_Elements.Storage_Array (1 .. Buffer_Size); + + --------------------------------- + -- Input and Output Operations -- + --------------------------------- + + procedure Read (Buffer : in Buffer_Type; Item : out Element_Type); + + procedure Write (Buffer : out Buffer_Type; Item : in Element_Type); + + ---------------- + -- Exceptions -- + ---------------- + + Data_Error : exception renames IO_Exceptions.Data_Error; + +end Ada.Storage_IO; diff --git a/gcc/ada/a-strbou.adb b/gcc/ada/a-strbou.adb new file mode 100644 index 00000000000..f85f91d85c6 --- /dev/null +++ b/gcc/ada/a-strbou.adb @@ -0,0 +1,1777 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strbou.ads b/gcc/ada/a-strbou.ads new file mode 100644 index 00000000000..55775aeb479 --- /dev/null +++ b/gcc/ada/a-strbou.ads @@ -0,0 +1,467 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; + +package Ada.Strings.Bounded is +pragma Preelaborate (Bounded); + + generic + Max : Positive; + -- Maximum length of a Bounded_String + + package Generic_Bounded_Length is + + Max_Length : constant Positive := Max; + + type Bounded_String is private; + + Null_Bounded_String : constant Bounded_String; + + subtype Length_Range is Natural range 0 .. Max_Length; + + function Length (Source : in Bounded_String) return Length_Range; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Bounded_String + (Source : in String; + Drop : in Truncation := Error) + return Bounded_String; + + function To_String (Source : in Bounded_String) return String; + + function Append + (Left, Right : in Bounded_String; + Drop : in Truncation := Error) + return Bounded_String; + + function Append + (Left : in Bounded_String; + Right : in String; + Drop : in Truncation := Error) + return Bounded_String; + + function Append + (Left : in String; + Right : in Bounded_String; + Drop : in Truncation := Error) + return Bounded_String; + + function Append + (Left : in Bounded_String; + Right : in Character; + Drop : in Truncation := Error) + return Bounded_String; + + function Append + (Left : in Character; + Right : in Bounded_String; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Append + (Source : in out Bounded_String; + New_Item : in Bounded_String; + Drop : in Truncation := Error); + + procedure Append + (Source : in out Bounded_String; + New_Item : in String; + Drop : in Truncation := Error); + + procedure Append + (Source : in out Bounded_String; + New_Item : in Character; + Drop : in Truncation := Error); + + function "&" + (Left, Right : in Bounded_String) + return Bounded_String; + + function "&" + (Left : in Bounded_String; + Right : in String) + return Bounded_String; + + function "&" + (Left : in String; + Right : in Bounded_String) + return Bounded_String; + + function "&" + (Left : in Bounded_String; + Right : in Character) + return Bounded_String; + + function "&" + (Left : in Character; + Right : in Bounded_String) + return Bounded_String; + + function Element + (Source : in Bounded_String; + Index : in Positive) + return Character; + + procedure Replace_Element + (Source : in out Bounded_String; + Index : in Positive; + By : in Character); + + function Slice + (Source : in Bounded_String; + Low : in Positive; + High : in Natural) + return String; + + function "=" (Left, Right : in Bounded_String) return Boolean; + + function "=" + (Left : in Bounded_String; + Right : in String) + return Boolean; + + function "=" + (Left : in String; + Right : in Bounded_String) + return Boolean; + + function "<" (Left, Right : in Bounded_String) return Boolean; + + function "<" + (Left : in Bounded_String; + Right : in String) + return Boolean; + + function "<" + (Left : in String; + Right : in Bounded_String) + return Boolean; + + function "<=" (Left, Right : in Bounded_String) return Boolean; + + function "<=" + (Left : in Bounded_String; + Right : in String) + return Boolean; + + function "<=" + (Left : in String; + Right : in Bounded_String) + return Boolean; + + function ">" (Left, Right : in Bounded_String) return Boolean; + + function ">" + (Left : in Bounded_String; + Right : in String) + return Boolean; + + function ">" + (Left : in String; + Right : in Bounded_String) + return Boolean; + + function ">=" (Left, Right : in Bounded_String) return Boolean; + + function ">=" + (Left : in Bounded_String; + Right : in String) + return Boolean; + + function ">=" + (Left : in String; + Right : in Bounded_String) + return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Index + (Source : in Bounded_String; + Pattern : in String; + Going : in Direction := Forward; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Index + (Source : in Bounded_String; + Pattern : in String; + Going : in Direction := Forward; + Mapping : in Maps.Character_Mapping_Function) + return Natural; + + function Index + (Source : in Bounded_String; + Set : in Maps.Character_Set; + Test : in Membership := Inside; + Going : in Direction := Forward) + return Natural; + + function Index_Non_Blank + (Source : in Bounded_String; + Going : in Direction := Forward) + return Natural; + + function Count + (Source : in Bounded_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Count + (Source : in Bounded_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping_Function) + return Natural; + + function Count + (Source : in Bounded_String; + Set : in Maps.Character_Set) + return Natural; + + procedure Find_Token + (Source : in Bounded_String; + Set : in Maps.Character_Set; + Test : in Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : in Bounded_String; + Mapping : in Maps.Character_Mapping) + return Bounded_String; + + procedure Translate + (Source : in out Bounded_String; + Mapping : in Maps.Character_Mapping); + + function Translate + (Source : in Bounded_String; + Mapping : in Maps.Character_Mapping_Function) + return Bounded_String; + + procedure Translate + (Source : in out Bounded_String; + Mapping : in Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : in Bounded_String; + Low : in Positive; + High : in Natural; + By : in String; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Replace_Slice + (Source : in out Bounded_String; + Low : in Positive; + High : in Natural; + By : in String; + Drop : in Truncation := Error); + + function Insert + (Source : in Bounded_String; + Before : in Positive; + New_Item : in String; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Insert + (Source : in out Bounded_String; + Before : in Positive; + New_Item : in String; + Drop : in Truncation := Error); + + function Overwrite + (Source : in Bounded_String; + Position : in Positive; + New_Item : in String; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Overwrite + (Source : in out Bounded_String; + Position : in Positive; + New_Item : in String; + Drop : in Truncation := Error); + + function Delete + (Source : in Bounded_String; + From : in Positive; + Through : in Natural) + return Bounded_String; + + procedure Delete + (Source : in out Bounded_String; + From : in Positive; + Through : in Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : in Bounded_String; + Side : in Trim_End) + return Bounded_String; + + procedure Trim + (Source : in out Bounded_String; + Side : in Trim_End); + + function Trim + (Source : in Bounded_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set) + return Bounded_String; + + procedure Trim + (Source : in out Bounded_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set); + + function Head + (Source : in Bounded_String; + Count : in Natural; + Pad : in Character := Space; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Head + (Source : in out Bounded_String; + Count : in Natural; + Pad : in Character := Space; + Drop : in Truncation := Error); + + function Tail + (Source : in Bounded_String; + Count : in Natural; + Pad : in Character := Space; + Drop : in Truncation := Error) + return Bounded_String; + + procedure Tail + (Source : in out Bounded_String; + Count : in Natural; + Pad : in Character := Space; + Drop : in Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + function "*" + (Left : in Natural; + Right : in Character) + return Bounded_String; + + function "*" + (Left : in Natural; + Right : in String) + return Bounded_String; + + function "*" + (Left : in Natural; + Right : in Bounded_String) + return Bounded_String; + + function Replicate + (Count : in Natural; + Item : in Character; + Drop : in Truncation := Error) + return Bounded_String; + + function Replicate + (Count : in Natural; + Item : in String; + Drop : in Truncation := Error) + return Bounded_String; + + function Replicate + (Count : in Natural; + Item : in Bounded_String; + Drop : in Truncation := Error) + return Bounded_String; + + private + + type Bounded_String is record + Length : Length_Range := 0; + Data : String (1 .. Max_Length) := (1 .. Max_Length => ASCII.NUL); + end record; + + Null_Bounded_String : constant Bounded_String := + (Length => 0, Data => (1 .. Max_Length => ASCII.NUL)); + + + -- Pragma Inline declarations (GNAT specific additions) + + pragma Inline ("="); + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + pragma Inline ("&"); + pragma Inline (Count); + pragma Inline (Element); + pragma Inline (Find_Token); + pragma Inline (Index); + pragma Inline (Index_Non_Blank); + pragma Inline (Length); + pragma Inline (Replace_Element); + pragma Inline (Slice); + pragma Inline (To_Bounded_String); + pragma Inline (To_String); + + end Generic_Bounded_Length; + +end Ada.Strings.Bounded; diff --git a/gcc/ada/a-stream.ads b/gcc/ada/a-stream.ads new file mode 100644 index 00000000000..c05c0b45962 --- /dev/null +++ b/gcc/ada/a-stream.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + +package Ada.Streams is +pragma Pure (Streams); + + type Root_Stream_Type is abstract tagged limited private; + + type Stream_Element is mod 2 ** Standard'Storage_Unit; + + type Stream_Element_Offset is range + -(2 ** (Standard'Address_Size - 1)) .. + +(2 ** (Standard'Address_Size - 1)) - 1; + + subtype Stream_Element_Count is + Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; + + type Stream_Element_Array is + array (Stream_Element_Offset range <>) of Stream_Element; + + procedure Read + (Stream : in out Root_Stream_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is abstract; + + procedure Write + (Stream : in out Root_Stream_Type; + Item : in Stream_Element_Array) + is abstract; + +private + + type Root_Stream_Type is abstract tagged limited null record; + +end Ada.Streams; diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb new file mode 100644 index 00000000000..8c10dec654c --- /dev/null +++ b/gcc/ada/a-strfix.adb @@ -0,0 +1,721 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strfix.ads b/gcc/ada/a-strfix.ads new file mode 100644 index 00000000000..edafb6fe11e --- /dev/null +++ b/gcc/ada/a-strfix.ads @@ -0,0 +1,256 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-string.ads b/gcc/ada/a-string.ads new file mode 100644 index 00000000000..65226d13711 --- /dev/null +++ b/gcc/ada/a-string.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strmap.adb b/gcc/ada/a-strmap.adb new file mode 100644 index 00000000000..4356327227d --- /dev/null +++ b/gcc/ada/a-strmap.adb @@ -0,0 +1,337 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strmap.ads b/gcc/ada/a-strmap.ads new file mode 100644 index 00000000000..c0f73be9ba2 --- /dev/null +++ b/gcc/ada/a-strmap.ads @@ -0,0 +1,424 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb new file mode 100644 index 00000000000..a869653f403 --- /dev/null +++ b/gcc/ada/a-strsea.adb @@ -0,0 +1,391 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads new file mode 100644 index 00000000000..9819bf4997d --- /dev/null +++ b/gcc/ada/a-strsea.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb new file mode 100644 index 00000000000..5d885905944 --- /dev/null +++ b/gcc/ada/a-strunb.adb @@ -0,0 +1,881 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-strunb.ads b/gcc/ada/a-strunb.ads new file mode 100644 index 00000000000..d3d4ff93f49 --- /dev/null +++ b/gcc/ada/a-strunb.ads @@ -0,0 +1,383 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb new file mode 100644 index 00000000000..f262b2ec990 --- /dev/null +++ b/gcc/ada/a-ststio.adb @@ -0,0 +1,463 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads new file mode 100644 index 00000000000..5f225ea970d --- /dev/null +++ b/gcc/ada/a-ststio.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stunau.adb b/gcc/ada/a-stunau.adb new file mode 100644 index 00000000000..272b7185a79 --- /dev/null +++ b/gcc/ada/a-stunau.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stunau.ads b/gcc/ada/a-stunau.ads new file mode 100644 index 00000000000..06c986c2d09 --- /dev/null +++ b/gcc/ada/a-stunau.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwibo.adb b/gcc/ada/a-stwibo.adb new file mode 100644 index 00000000000..8d2a0cb7410 --- /dev/null +++ b/gcc/ada/a-stwibo.adb @@ -0,0 +1,1812 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwibo.ads b/gcc/ada/a-stwibo.ads new file mode 100644 index 00000000000..8348fe67c03 --- /dev/null +++ b/gcc/ada/a-stwibo.ads @@ -0,0 +1,484 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb new file mode 100644 index 00000000000..e998bcdbfae --- /dev/null +++ b/gcc/ada/a-stwifi.adb @@ -0,0 +1,657 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwifi.ads b/gcc/ada/a-stwifi.ads new file mode 100644 index 00000000000..a4bf2d9bddd --- /dev/null +++ b/gcc/ada/a-stwifi.ads @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwima.adb b/gcc/ada/a-stwima.adb new file mode 100644 index 00000000000..f552f1d72da --- /dev/null +++ b/gcc/ada/a-stwima.adb @@ -0,0 +1,758 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwima.ads b/gcc/ada/a-stwima.ads new file mode 100644 index 00000000000..b1e3d2cab02 --- /dev/null +++ b/gcc/ada/a-stwima.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwise.adb b/gcc/ada/a-stwise.adb new file mode 100644 index 00000000000..9e58fda2c55 --- /dev/null +++ b/gcc/ada/a-stwise.adb @@ -0,0 +1,324 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwise.ads b/gcc/ada/a-stwise.ads new file mode 100644 index 00000000000..b8abaf3d9cf --- /dev/null +++ b/gcc/ada/a-stwise.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwiun.adb b/gcc/ada/a-stwiun.adb new file mode 100644 index 00000000000..f6392682b16 --- /dev/null +++ b/gcc/ada/a-stwiun.adb @@ -0,0 +1,917 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-stwiun.ads b/gcc/ada/a-stwiun.ads new file mode 100644 index 00000000000..91433e7d1f3 --- /dev/null +++ b/gcc/ada/a-stwiun.ads @@ -0,0 +1,408 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-suteio.adb b/gcc/ada/a-suteio.adb new file mode 100644 index 00000000000..1cc2f68c21f --- /dev/null +++ b/gcc/ada/a-suteio.adb @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-suteio.ads b/gcc/ada/a-suteio.ads new file mode 100644 index 00000000000..01e1b2dbc3e --- /dev/null +++ b/gcc/ada/a-suteio.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-swmwco.ads b/gcc/ada/a-swmwco.ads new file mode 100644 index 00000000000..e5393b6d4d7 --- /dev/null +++ b/gcc/ada/a-swmwco.ads @@ -0,0 +1,455 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-swuwti.adb b/gcc/ada/a-swuwti.adb new file mode 100644 index 00000000000..e7c93c6f4ea --- /dev/null +++ b/gcc/ada/a-swuwti.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-swuwti.ads b/gcc/ada/a-swuwti.ads new file mode 100644 index 00000000000..61aa6ecb18b --- /dev/null +++ b/gcc/ada/a-swuwti.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-sytaco.adb b/gcc/ada/a-sytaco.adb new file mode 100644 index 00000000000..e99ea6e0866 --- /dev/null +++ b/gcc/ada/a-sytaco.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads new file mode 100644 index 00000000000..81369b56c24 --- /dev/null +++ b/gcc/ada/a-sytaco.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb new file mode 100644 index 00000000000..b11330d41cb --- /dev/null +++ b/gcc/ada/a-tags.adb @@ -0,0 +1,536 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads new file mode 100644 index 00000000000..2c0daef98a8 --- /dev/null +++ b/gcc/ada/a-tags.ads @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb new file mode 100644 index 00000000000..395906334d1 --- /dev/null +++ b/gcc/ada/a-tasatt.adb @@ -0,0 +1,808 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tasatt.ads b/gcc/ada/a-tasatt.ads new file mode 100644 index 00000000000..142ff0d997b --- /dev/null +++ b/gcc/ada/a-tasatt.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb new file mode 100644 index 00000000000..2c444a3e2de --- /dev/null +++ b/gcc/ada/a-taside.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads new file mode 100644 index 00000000000..dc02b3850d4 --- /dev/null +++ b/gcc/ada/a-taside.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb new file mode 100644 index 00000000000..8a448c87b5f --- /dev/null +++ b/gcc/ada/a-teioed.adb @@ -0,0 +1,2827 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-teioed.ads b/gcc/ada/a-teioed.ads new file mode 100644 index 00000000000..8eb832e3fd8 --- /dev/null +++ b/gcc/ada/a-teioed.ads @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb new file mode 100644 index 00000000000..36a6a167ba8 --- /dev/null +++ b/gcc/ada/a-textio.adb @@ -0,0 +1,1804 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads new file mode 100644 index 00000000000..2fbb2d6da9e --- /dev/null +++ b/gcc/ada/a-textio.ads @@ -0,0 +1,442 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ticoau.adb b/gcc/ada/a-ticoau.adb new file mode 100644 index 00000000000..d8c785a0986 --- /dev/null +++ b/gcc/ada/a-ticoau.adb @@ -0,0 +1,206 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ticoau.ads b/gcc/ada/a-ticoau.ads new file mode 100644 index 00000000000..edf6d3f772d --- /dev/null +++ b/gcc/ada/a-ticoau.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ticoio.adb b/gcc/ada/a-ticoio.adb new file mode 100644 index 00000000000..bf9c0b3fb3c --- /dev/null +++ b/gcc/ada/a-ticoio.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-ticoio.ads b/gcc/ada/a-ticoio.ads new file mode 100644 index 00000000000..d3c154f61b4 --- /dev/null +++ b/gcc/ada/a-ticoio.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tideau.adb b/gcc/ada/a-tideau.adb new file mode 100644 index 00000000000..d8ccce01b27 --- /dev/null +++ b/gcc/ada/a-tideau.adb @@ -0,0 +1,264 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tideau.ads b/gcc/ada/a-tideau.ads new file mode 100644 index 00000000000..55045a27f43 --- /dev/null +++ b/gcc/ada/a-tideau.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tideio.adb b/gcc/ada/a-tideio.adb new file mode 100644 index 00000000000..6f0b0f15a75 --- /dev/null +++ b/gcc/ada/a-tideio.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tideio.ads b/gcc/ada/a-tideio.ads new file mode 100644 index 00000000000..2c1e9631914 --- /dev/null +++ b/gcc/ada/a-tideio.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb new file mode 100644 index 00000000000..b1a723d8bfb --- /dev/null +++ b/gcc/ada/a-tienau.adb @@ -0,0 +1,300 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tienau.ads b/gcc/ada/a-tienau.ads new file mode 100644 index 00000000000..ebbae7869f6 --- /dev/null +++ b/gcc/ada/a-tienau.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tienio.adb b/gcc/ada/a-tienio.adb new file mode 100644 index 00000000000..a01d8a6a83b --- /dev/null +++ b/gcc/ada/a-tienio.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tienio.ads b/gcc/ada/a-tienio.ads new file mode 100644 index 00000000000..e69e47aa4d8 --- /dev/null +++ b/gcc/ada/a-tienio.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb new file mode 100644 index 00000000000..a804578d995 --- /dev/null +++ b/gcc/ada/a-tifiio.adb @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tifiio.ads b/gcc/ada/a-tifiio.ads new file mode 100644 index 00000000000..a23907b5bc5 --- /dev/null +++ b/gcc/ada/a-tifiio.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb new file mode 100644 index 00000000000..edd3f9c5c84 --- /dev/null +++ b/gcc/ada/a-tiflau.adb @@ -0,0 +1,231 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiflau.ads b/gcc/ada/a-tiflau.ads new file mode 100644 index 00000000000..1322399b848 --- /dev/null +++ b/gcc/ada/a-tiflau.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiflio.adb b/gcc/ada/a-tiflio.adb new file mode 100644 index 00000000000..1691cbfc654 --- /dev/null +++ b/gcc/ada/a-tiflio.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiflio.ads b/gcc/ada/a-tiflio.ads new file mode 100644 index 00000000000..0ae47b17738 --- /dev/null +++ b/gcc/ada/a-tiflio.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb new file mode 100644 index 00000000000..f3c67af8246 --- /dev/null +++ b/gcc/ada/a-tigeau.adb @@ -0,0 +1,480 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tigeau.ads b/gcc/ada/a-tigeau.ads new file mode 100644 index 00000000000..dabc6361734 --- /dev/null +++ b/gcc/ada/a-tigeau.ads @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- -- +-- 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; diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb new file mode 100644 index 00000000000..3e44a206b89 --- /dev/null +++ b/gcc/ada/a-tiinau.adb @@ -0,0 +1,297 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiinau.ads b/gcc/ada/a-tiinau.ads new file mode 100644 index 00000000000..b61d639b171 --- /dev/null +++ b/gcc/ada/a-tiinau.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiinio.adb b/gcc/ada/a-tiinio.adb new file mode 100644 index 00000000000..b52d91e7511 --- /dev/null +++ b/gcc/ada/a-tiinio.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiinio.ads b/gcc/ada/a-tiinio.ads new file mode 100644 index 00000000000..a70bc0d4cb6 --- /dev/null +++ b/gcc/ada/a-tiinio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-timoau.adb b/gcc/ada/a-timoau.adb new file mode 100644 index 00000000000..78425b812aa --- /dev/null +++ b/gcc/ada/a-timoau.adb @@ -0,0 +1,307 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-timoau.ads b/gcc/ada/a-timoau.ads new file mode 100644 index 00000000000..5fa35dc4ede --- /dev/null +++ b/gcc/ada/a-timoau.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-timoio.adb b/gcc/ada/a-timoio.adb new file mode 100644 index 00000000000..5fc3547a7d2 --- /dev/null +++ b/gcc/ada/a-timoio.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-timoio.ads b/gcc/ada/a-timoio.ads new file mode 100644 index 00000000000..4609a665650 --- /dev/null +++ b/gcc/ada/a-timoio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiocst.adb b/gcc/ada/a-tiocst.adb new file mode 100644 index 00000000000..54ee88672b4 --- /dev/null +++ b/gcc/ada/a-tiocst.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-tiocst.ads b/gcc/ada/a-tiocst.ads new file mode 100644 index 00000000000..0fe1f72517e --- /dev/null +++ b/gcc/ada/a-tiocst.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-titest.adb b/gcc/ada/a-titest.adb new file mode 100644 index 00000000000..2eafb22b2f6 --- /dev/null +++ b/gcc/ada/a-titest.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-titest.ads b/gcc/ada/a-titest.ads new file mode 100644 index 00000000000..626c2f1acb3 --- /dev/null +++ b/gcc/ada/a-titest.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads new file mode 100644 index 00000000000..8df74c8efdc --- /dev/null +++ b/gcc/ada/a-unccon.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- 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); diff --git a/gcc/ada/a-uncdea.ads b/gcc/ada/a-uncdea.ads new file mode 100644 index 00000000000..5a15efa6f62 --- /dev/null +++ b/gcc/ada/a-uncdea.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- 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); diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb new file mode 100644 index 00000000000..ce3612051e3 --- /dev/null +++ b/gcc/ada/a-witeio.adb @@ -0,0 +1,1823 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads new file mode 100644 index 00000000000..c51e331d847 --- /dev/null +++ b/gcc/ada/a-witeio.ads @@ -0,0 +1,482 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcoau.adb b/gcc/ada/a-wtcoau.adb new file mode 100644 index 00000000000..26c2c267fe1 --- /dev/null +++ b/gcc/ada/a-wtcoau.adb @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcoau.ads b/gcc/ada/a-wtcoau.ads new file mode 100644 index 00000000000..071c481fa63 --- /dev/null +++ b/gcc/ada/a-wtcoau.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcoio.adb b/gcc/ada/a-wtcoio.adb new file mode 100644 index 00000000000..6ffa0a8de2a --- /dev/null +++ b/gcc/ada/a-wtcoio.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcoio.ads b/gcc/ada/a-wtcoio.ads new file mode 100644 index 00000000000..a1576cd25a7 --- /dev/null +++ b/gcc/ada/a-wtcoio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcstr.adb b/gcc/ada/a-wtcstr.adb new file mode 100644 index 00000000000..392b36e1d58 --- /dev/null +++ b/gcc/ada/a-wtcstr.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtcstr.ads b/gcc/ada/a-wtcstr.ads new file mode 100644 index 00000000000..8ad6d2cd680 --- /dev/null +++ b/gcc/ada/a-wtcstr.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtdeau.adb b/gcc/ada/a-wtdeau.adb new file mode 100644 index 00000000000..830c93c93b7 --- /dev/null +++ b/gcc/ada/a-wtdeau.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtdeau.ads b/gcc/ada/a-wtdeau.ads new file mode 100644 index 00000000000..5e11ede5133 --- /dev/null +++ b/gcc/ada/a-wtdeau.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtdeio.adb b/gcc/ada/a-wtdeio.adb new file mode 100644 index 00000000000..83bdad4addc --- /dev/null +++ b/gcc/ada/a-wtdeio.adb @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtdeio.ads b/gcc/ada/a-wtdeio.ads new file mode 100644 index 00000000000..8f1413f7e60 --- /dev/null +++ b/gcc/ada/a-wtdeio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb new file mode 100644 index 00000000000..b7783a2dcee --- /dev/null +++ b/gcc/ada/a-wtedit.adb @@ -0,0 +1,2785 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtedit.ads b/gcc/ada/a-wtedit.ads new file mode 100644 index 00000000000..1c4e57d328a --- /dev/null +++ b/gcc/ada/a-wtedit.ads @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb new file mode 100644 index 00000000000..ddbbee9eab9 --- /dev/null +++ b/gcc/ada/a-wtenau.adb @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtenau.ads b/gcc/ada/a-wtenau.ads new file mode 100644 index 00000000000..0a7d01f0deb --- /dev/null +++ b/gcc/ada/a-wtenau.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtenio.adb b/gcc/ada/a-wtenio.adb new file mode 100644 index 00000000000..f8030772e5b --- /dev/null +++ b/gcc/ada/a-wtenio.adb @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtenio.ads b/gcc/ada/a-wtenio.ads new file mode 100644 index 00000000000..dbd2154417f --- /dev/null +++ b/gcc/ada/a-wtenio.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtfiio.adb b/gcc/ada/a-wtfiio.adb new file mode 100644 index 00000000000..200316adf40 --- /dev/null +++ b/gcc/ada/a-wtfiio.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtfiio.ads b/gcc/ada/a-wtfiio.ads new file mode 100644 index 00000000000..13a6648b047 --- /dev/null +++ b/gcc/ada/a-wtfiio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb new file mode 100644 index 00000000000..e4331c4b961 --- /dev/null +++ b/gcc/ada/a-wtflau.adb @@ -0,0 +1,231 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtflau.ads b/gcc/ada/a-wtflau.ads new file mode 100644 index 00000000000..f963475c67b --- /dev/null +++ b/gcc/ada/a-wtflau.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtflio.adb b/gcc/ada/a-wtflio.adb new file mode 100644 index 00000000000..cec9cf81f5c --- /dev/null +++ b/gcc/ada/a-wtflio.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtflio.ads b/gcc/ada/a-wtflio.ads new file mode 100644 index 00000000000..2ba261f4c99 --- /dev/null +++ b/gcc/ada/a-wtflio.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb new file mode 100644 index 00000000000..cc10554ce60 --- /dev/null +++ b/gcc/ada/a-wtgeau.adb @@ -0,0 +1,520 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtgeau.ads b/gcc/ada/a-wtgeau.ads new file mode 100644 index 00000000000..ed03d521517 --- /dev/null +++ b/gcc/ada/a-wtgeau.ads @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtinau.adb b/gcc/ada/a-wtinau.adb new file mode 100644 index 00000000000..31027980228 --- /dev/null +++ b/gcc/ada/a-wtinau.adb @@ -0,0 +1,299 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtinau.ads b/gcc/ada/a-wtinau.ads new file mode 100644 index 00000000000..7b310e69a6a --- /dev/null +++ b/gcc/ada/a-wtinau.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtinio.adb b/gcc/ada/a-wtinio.adb new file mode 100644 index 00000000000..c433bba63f8 --- /dev/null +++ b/gcc/ada/a-wtinio.adb @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtinio.ads b/gcc/ada/a-wtinio.ads new file mode 100644 index 00000000000..61ea591db14 --- /dev/null +++ b/gcc/ada/a-wtinio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb new file mode 100644 index 00000000000..16e37db2d03 --- /dev/null +++ b/gcc/ada/a-wtmoau.adb @@ -0,0 +1,309 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtmoau.ads b/gcc/ada/a-wtmoau.ads new file mode 100644 index 00000000000..7ccb46a2d19 --- /dev/null +++ b/gcc/ada/a-wtmoau.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtmoio.adb b/gcc/ada/a-wtmoio.adb new file mode 100644 index 00000000000..5ceb2d65bb8 --- /dev/null +++ b/gcc/ada/a-wtmoio.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wtmoio.ads b/gcc/ada/a-wtmoio.ads new file mode 100644 index 00000000000..b16241763fb --- /dev/null +++ b/gcc/ada/a-wtmoio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wttest.adb b/gcc/ada/a-wttest.adb new file mode 100644 index 00000000000..e57d66cff44 --- /dev/null +++ b/gcc/ada/a-wttest.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-wttest.ads b/gcc/ada/a-wttest.ads new file mode 100644 index 00000000000..05b10777894 --- /dev/null +++ b/gcc/ada/a-wttest.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def new file mode 100644 index 00000000000..b583c935eec --- /dev/null +++ b/gcc/ada/ada-tree.def @@ -0,0 +1,88 @@ +/**************************************************************************** + * * + * 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) diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h new file mode 100644 index 00000000000..73e8d78102c --- /dev/null +++ b/gcc/ada/ada-tree.h @@ -0,0 +1,232 @@ +/**************************************************************************** + * * + * 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) diff --git a/gcc/ada/ada.ads b/gcc/ada/ada.ads new file mode 100644 index 00000000000..a52cc119ab3 --- /dev/null +++ b/gcc/ada/ada.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/ada.h b/gcc/ada/ada.h new file mode 100644 index 00000000000..20418b6877f --- /dev/null +++ b/gcc/ada/ada.h @@ -0,0 +1,76 @@ +/**************************************************************************** + * * + * 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))) diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c new file mode 100644 index 00000000000..aa4af1a73f8 --- /dev/null +++ b/gcc/ada/adaint.c @@ -0,0 +1,2002 @@ +/**************************************************************************** + * * + * 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 + +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 diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h new file mode 100644 index 00000000000..ca8ef6f737a --- /dev/null +++ b/gcc/ada/adaint.h @@ -0,0 +1,139 @@ +/**************************************************************************** + * * + * 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 diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb new file mode 100644 index 00000000000..58312cdc9cc --- /dev/null +++ b/gcc/ada/ali-util.adb @@ -0,0 +1,514 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads new file mode 100644 index 00000000000..ace733a4acd --- /dev/null +++ b/gcc/ada/ali-util.ads @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb new file mode 100644 index 00000000000..0909b38034f --- /dev/null +++ b/gcc/ada/ali.adb @@ -0,0 +1,1376 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads new file mode 100644 index 00000000000..6924919cfc3 --- /dev/null +++ b/gcc/ada/ali.ads @@ -0,0 +1,710 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads new file mode 100644 index 00000000000..8250c8dcff1 --- /dev/null +++ b/gcc/ada/alloc.ads @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c new file mode 100644 index 00000000000..63b426d4ede --- /dev/null +++ b/gcc/ada/argv.c @@ -0,0 +1,110 @@ +/**************************************************************************** + * * + * 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])); +} diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb new file mode 100644 index 00000000000..d7b1af1aec8 --- /dev/null +++ b/gcc/ada/atree.adb @@ -0,0 +1,5923 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads new file mode 100644 index 00000000000..8a4da3f9ab6 --- /dev/null +++ b/gcc/ada/atree.ads @@ -0,0 +1,2581 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h new file mode 100644 index 00000000000..470adfcd6cd --- /dev/null +++ b/gcc/ada/atree.h @@ -0,0 +1,606 @@ +/**************************************************************************** + * * + * 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) |